-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Utils.PathPiece ( nullaryToPathPiece', nullaryToPathPiece , nullaryPathPiece', nullaryPathPiece, finitePathPiece , derivePathPiece , splitCamel, dropCamel , camelToPathPiece, camelToPathPiece', camelToPathPiece'' , nameToPathPiece, nameToPathPiece' , kebabToCamel , tuplePathPiece , pathPieceJSON, pathPieceJSONKey , pathPieceBinary , pathPieceHttpApiData , pathPieceJoined ) where import ClassyPrelude.Yesod import Language.Haskell.TH import qualified Language.Haskell.TH.Syntax as TH (Lift(..)) import Language.Haskell.TH.Datatype import Data.Universe import qualified Data.Text as Text import qualified Data.Char as Char import Data.Map ((!)) import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMap import Numeric.Natural import Data.List (foldl) import Data.Aeson.Types import qualified Data.Aeson.Types as Aeson import Control.Monad.Fail import Data.Binary (Binary) import qualified Data.Binary as Binary import Control.Lens import Data.Generics.Product.Types import Web.HttpApiData import Data.ByteString.Lazy.Base32 import qualified Data.CaseInsensitive as CI import Data.Containers.ListUtils mkFiniteFromPathPiece :: Name -> Q ([Dec], Exp) mkFiniteFromPathPiece finiteType = do mapName <- newName $ "pathPieceMap" <> nameBase finiteType let decs = sequence [ pragInlD mapName NoInline FunLike AllPhases , sigD mapName [t|HashMap Text $(conT finiteType)|] , funD mapName [ clause [] (normalB [e|HashMap.fromList $ map (toPathPiece &&& id) universeF|]) [] ] ] (,) <$> decs <*> [e|flip HashMap.lookup $(varE mapName)|] nullaryToPathPiece' :: Name -> (Name -> Text) -> ExpQ nullaryToPathPiece' nullaryType mangle = do TyConI (DataD _ _ _ _ constructors _) <- reify nullaryType helperName <- newName "helper" let toClause (NormalC cName []) = clause [conP cName []] (normalB . TH.lift $ mangle cName) [] toClause con = fail $ "Unsupported constructor: " ++ show con helperDec = funD helperName $ map toClause constructors letE [helperDec] $ varE helperName nullaryToPathPiece :: Name -> (Text -> Text) -> ExpQ nullaryToPathPiece nullaryType = nullaryToPathPiece' nullaryType . flip (.) (Text.pack . nameBase) nullaryPathPiece' :: Name -> (Name -> Text) -> DecsQ nullaryPathPiece' nullaryType mangle = do (finDecs, finExp) <- mkFiniteFromPathPiece nullaryType sequence . (map return finDecs ++) . pure $ instanceD (cxt []) [t|PathPiece $(conT nullaryType)|] [ funD 'toPathPiece [ clause [] (normalB $ nullaryToPathPiece' nullaryType mangle) [] ] , funD 'fromPathPiece [ clause [] (normalB $ return finExp) [] ] ] nullaryPathPiece :: Name -> (Text -> Text) -> DecsQ nullaryPathPiece nullaryType = nullaryPathPiece' nullaryType . flip (.) (Text.pack . nameBase) finitePathPiece :: Name -> [Text] -> DecsQ finitePathPiece finiteType verbs = do (finDecs, finExp) <- mkFiniteFromPathPiece finiteType sequence . (map return finDecs ++) . pure $ instanceD (cxt []) [t|PathPiece $(conT finiteType)|] [ funD 'toPathPiece [ clause [] (normalB [|(Map.fromList (zip universeF verbs) !)|]) [] ] , funD 'fromPathPiece [ clause [] (normalB $ return finExp) [] ] ] pathPieceJoined :: Text -> Prism' Text [Text] pathPieceJoined sep = prism' joinPP splitPP where b32Prefix = "b32." textable :: [Text] -> Bool textable ts = maybe False (not . (b32Prefix `Text.isPrefixOf`)) (ts ^? _head) && all (textable' . Text.splitOn sep) ts where textable' ts' = not (all Text.null ts') && maybe False (not . Text.null) (ts' ^? _last) && maybe False (not . Text.null) (ts' ^? _head) && not (consecutiveNulls ts') && all textable'' ts' textable'' t = none (`Text.isSuffixOf` t) [ Text.dropEnd i sep | i <- [0..(Text.length sep - 1)]] && none (`Text.isPrefixOf` t) [ Text.drop i sep | i <- [0..(Text.length sep - 1)]] consecutiveNulls (x1:x2:xs) | Text.null x1, Text.null x2 = True | otherwise = consecutiveNulls $ x2 : xs consecutiveNulls _ = False joinPP :: [Text] -> Text joinPP ts | textable ts = Text.intercalate sep $ map (Text.replace sep (sep <> sep)) ts | otherwise = b32Prefix <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode ts) splitPP :: Text -> Maybe [Text] splitPP t | Just b <- Text.stripPrefix b32Prefix t = if | Right bin <- decodeBase32 . fromStrict $ encodeUtf8 b , Right (onull -> True, _, ts) <- Binary.decodeOrFail bin -> Just ts | otherwise -> Nothing | otherwise = assertM' textable . go [] $ Text.splitOn sep t where go :: [Text] -> [Text] -> [Text] go acc [] = acc go acc (x1:x2:x3:xs) | Text.null x2 = go acc $ (x1 <> sep <> x3) : xs go acc (x:xs) = x : go acc xs assertM' p x = x <$ guard (p x) derivePathPiece :: Name -> (Text -> Text) -> Text -> DecsQ derivePathPiece adt mangle joinPP = do let mangle' = TH.lift . mangle . pack . nameBase DatatypeInfo{..} <- reifyDatatype adt mapName <- newName $ "pathPieceConstructorMap" <> nameBase adt let toClause ConstructorInfo{..} = do vars <- mapM (const $ newName "x") constructorFields clause [conP constructorName $ map varP vars] (normalB [e|review (pathPieceJoined joinPP) $ $(mangle' constructorName) : $(listE $ map (\v -> [e|toPathPiece $(varE v)|]) vars)|]) [] fromClause = do constrName <- newName "c" argsName <- newName "args" clause [viewP [e|preview (pathPieceJoined joinPP)|] $ conP 'Just [infixP (varP constrName) '(:) (varP argsName)]] (normalB [e|HashMap.lookup $(varE constrName) $(varE mapName) >>= ($ $(varE argsName))|]) [] finDecs = [ pragInlD mapName NoInline FunLike AllPhases , sigD mapName $ forallT [] (cxt iCxt) [t|HashMap Text ([Text] -> Maybe $typ)|] , funD mapName [ clause [] (normalB finClause) [] ] ] where finClause = ([e|HashMap.fromList|] `appE`) . listE $ map listItem datatypeCons listItem ConstructorInfo{..} = do vars <- mapM (const $ newName "x") constructorFields tupE [ mangle' constructorName , lamCaseE [ match (listP $ map varP vars) (normalB $ case vars of [] -> [e|Just $(conE constructorName)|] v : vs -> foldl' (\acc v' -> [e|$(acc) <*> fromPathPiece $(varE v')|]) [e|$(conE constructorName) <$> fromPathPiece $(varE v)|] vs ) [] , match wildP (normalB [e|Nothing|]) [] ] ] typ = foldl (\t bndr -> t `appT` varT (tvarName bndr)) (conT adt) datatypeVars iCxt = map (appT [t|PathPiece|] . pure) $ filter (\t -> any (flip (elemOf types) t) usedTVars) fieldTypes where usedTVars = filter (\n -> any (`usesVar` n) datatypeCons) $ map tvarName datatypeVars usesVar ConstructorInfo{..} n | n `elem` map tvarName constructorVars = False | otherwise = any (elemOf types n) constructorFields fieldTypes = nubOrd $ concatMap constructorFields datatypeCons tvarName (PlainTV n) = n tvarName (KindedTV n _) = n sequence . (finDecs ++ ) . pure $ instanceD (cxt iCxt) [t|PathPiece $typ|] [ funD 'toPathPiece (map toClause datatypeCons) , funD 'fromPathPiece [ fromClause , clause [wildP] (normalB [e|Nothing|]) [] ] ] splitCamel :: Textual t => t -> [t] splitCamel = map fromList . reverse . helper (error "hasChange undefined at start of string") [] "" . otoList where helper _hadChange items thisWord [] = reverse thisWord : items helper _hadChange items [] (c:cs) = helper True items [c] cs helper hadChange items ws@(w:ws') (c:cs) | sameCategory w c , null ws' = helper (Char.isLower w || Char.isDigit w) items (c:ws) cs | sameCategory w c = helper hadChange items (c:ws) cs | Char.isLower w , Char.isUpper c = helper True (reverse ws :items) [c] cs | null ws' = helper True items (c:ws) cs | not hadChange = helper True (reverse ws':items) [c,w] cs | otherwise = helper True (reverse ws :items) [c] cs sameCategory = (==) `on` Char.generalCategory dropCamel :: Textual t => Int -> t -> t dropCamel n = mconcat . drop n . splitCamel -- | convert CamelCase to kebab-case, dropping parts at the start and the end camelToPathPiece'' :: Textual t => Natural -> Natural -> t -> t camelToPathPiece'' dropNStart dropNEnd = intercalate "-" . map toLower . drop (fromIntegral dropNStart) . dropEnd (fromIntegral dropNEnd) . splitCamel -- | convert CamelCase to kebab-case, dropping parts at the start camelToPathPiece' :: Textual t => Natural -> t -> t camelToPathPiece' dropN = intercalate "-" . map toLower . drop (fromIntegral dropN) . splitCamel -- | convert CamelCase to kebab-case suitable for path pieces camelToPathPiece :: Textual t => t -> t camelToPathPiece = camelToPathPiece' 0 nameToPathPiece' :: Textual t => Natural -> Name -> t nameToPathPiece' dropN = camelToPathPiece' dropN . repack . nameBase nameToPathPiece :: Textual t => Name -> t nameToPathPiece = nameToPathPiece' 0 -- | convert kebab-case to CamelCase kebabToCamel :: Text -> Text -- kebabToCamel = Text.filter (not . Char.isSpace) . Text.toTitle . Text.replace "-" " " -- eliminates all space kebabToCamel = mconcat . fmap Text.toTitle . Text.split ('-'==) -- preserves existing spaces tuplePathPiece :: Int -> DecQ tuplePathPiece tupleDim = do let tupleSeparator :: Text tupleSeparator = "," xs <- replicateM tupleDim $ newName "x" :: Q [Name] xs' <- replicateM tupleDim $ newName "x'" :: Q [Name] let tupleType = foldl appT (tupleT tupleDim) $ map varT xs tCxt = cxt [ [t|PathPiece $(varT x)|] | x <- xs ] t <- newName "t" instanceD tCxt [t|PathPiece $tupleType|] [ funD 'toPathPiece [ clause [tupP $ map varP xs] (normalB [e|review (pathPieceJoined tupleSeparator) $(listE $ map (appE [e|toPathPiece|] . varE) xs)|]) [] ] , funD 'fromPathPiece [ clause [varP t] (normalB . doE $ concat [ pure $ bindS (listP $ map varP xs) [e|preview (pathPieceJoined tupleSeparator) $(varE t)|] , [ bindS (varP x') [e|fromPathPiece $(varE x)|] | (x, x') <- zip xs xs' ] , pure $ noBindS [e|return $(tupE $ map varE xs')|] ]) [] ] ] pathPieceJSONKey :: Name -> DecsQ -- ^ Derive `ToJSONKey`- and `FromJSONKey`-Instances from a `PathPiece`-Instance pathPieceJSONKey tName = [d| instance ToJSONKey $(conT tName) where toJSONKey = toJSONKeyText toPathPiece instance FromJSONKey $(conT tName) where fromJSONKey = FromJSONKeyTextParser $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t |] pathPieceJSON :: Name -> DecsQ -- ^ Derive `ToJSON`- and `FromJSON`-Instances from a `PathPiece`-Instance pathPieceJSON tName = [d| instance ToJSON $(conT tName) where toJSON = Aeson.String . toPathPiece instance FromJSON $(conT tName) where parseJSON = Aeson.withText $(TH.lift $ nameBase tName) $ \t -> maybe (fail $ "Could not parse ‘" <> unpack t <> "’ as value for " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return $ fromPathPiece t |] pathPieceBinary :: Name -> DecsQ pathPieceBinary tName = [d| instance Binary $(conT tName) where get = Binary.get >>= maybe (fail $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") return . fromPathPiece put = Binary.put . toPathPiece |] pathPieceHttpApiData :: Name -> DecsQ pathPieceHttpApiData tName = [d| instance ToHttpApiData $(conT tName) where toUrlPiece = toPathPiece instance FromHttpApiData $(conT tName) where parseUrlPiece = maybe (Left $ "Could not parse value of " <> $(TH.lift $ nameBase tName) <> " via PathPiece") Right . fromPathPiece |]