fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore: generalize embedRenderMessage

Browse Source
This commit is contained in:
Gregor Kleen 2021-03-18 18:47:34 +01:00
parent 51a90bbb5f
commit 0c37cbff64
1 changed files with 23 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

44
src/Utils/TH.hs
View File

@ -131,33 +131,35 @@ embedRenderMessage :: Name -- ^ Foundation type
-> (Text -> Text) -- ^ Mangle constructor names
-> DecsQ
-- ^ @embedRenderMessage ''Foundation ''MessageType mangle@ declares a
-- `RenderMessage Foundation MessageType` instance expecting the default
-- message-datatype (@FoundationMessage@) to contain one constructor for each
-- constructor of @MessageType@, taking the same arguments:
-- `RenderMessage Foundation MessageType` instance expecting there
-- to be one constructor for each constructor of @MessageType@ in
-- scope, taking the same arguments:
--
-- > data NewMessage = NewMessageOne | NewMessageTwo
-- > data FoundationMessage = MsgOne | MsgTwo
-- > data NewMessage = NewMessageOne | NewMessageTwo | NewMessageThree
-- > data FoundationMessage = MsgOne | MsgThree
-- > data FoundationEvenMessage = MsgTwo
-- >
-- > -- embedRenderMessage ''Foundation ''NewMessage (drop 2 . splitCamel)
-- > -- embedRenderMessage ''Foundation ''NewMessage $ drop 2 . splitCamel
-- > instance RenderMessage Foundation NewMessage where
-- > renderMessage f ls = renderMessage f ls . \case
-- > NewMessageOne -> MsgOne
-- > NewMessageTwo -> MsgTwo
-- > renderMessage f ls = \case
-- > NewMessageOne -> renderMessage f ls MsgOne
-- > NewMessageTwo -> renderMessage f ls MsgTwo
embedRenderMessage f inner mangle = do
DatatypeInfo{..} <- reifyDatatype inner
let
matches :: [MatchQ]
matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
vars <- forM constructorFields $ \_ -> newName "x"
let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
match (conP constructorName $ map varP vars) (normalB body) []
f' <- newName "f"
ls <- newName "ls"
let
matches :: [MatchQ]
matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
vars <- forM constructorFields $ \_ -> newName "x"
let constr = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
match (conP constructorName $ map varP vars) (normalB [e|renderMessage $(varE f') $(varE ls) $(constr)|]) []
pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT inner)|]
[ funD 'renderMessage
[ clause [varP f', varP ls] (normalB [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) []
[ clause [varP f', varP ls] (normalB $ lamCaseE matches) []
]
]
@ -169,19 +171,19 @@ embedRenderMessageVariant f newT mangle = do
[ConstructorInfo{ constructorName = newtypeName, constructorFields = [ ConT newtypeInner ] }] <- datatypeCons <$> reifyDatatype newT
DatatypeInfo{..} <- reifyDatatype newtypeInner
f' <- newName "f"
ls <- newName "ls"
let
matches :: [MatchQ]
matches = flip map datatypeCons $ \ConstructorInfo{..} -> do
vars <- forM constructorFields $ \_ -> newName "x"
let body = foldl (\e v -> e `appE` varE v) (conE . mkName . unpack $ "Msg" <> mangle (pack $ nameBase constructorName)) vars
match (conP newtypeName [conP constructorName $ map varP vars]) (normalB body) []
f' <- newName "f"
ls <- newName "ls"
match (conP newtypeName [conP constructorName $ map varP vars]) (normalB [e|renderMessage $(varE f') $(varE ls) $(body)|]) []
pure <$> instanceD (cxt []) [t|RenderMessage $(conT f) $(conT newT)|]
[ funD 'renderMessage
[ clause [varP f', varP ls] (normalB [e|renderMessage $(varE f') $(varE ls) . $(lamCaseE matches)|]) []
[ clause [varP f', varP ls] (normalB $ lamCaseE matches) []
]
]