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