308 lines
13 KiB
Haskell
308 lines
13 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||
--
|
||
-- 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
|
||
|]
|