From 0c37cbff64d89b8a0bc525f3827c6c1687ef9e0b Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gregor.kleen@ifi.lmu.de>
Date: Thu, 18 Mar 2021 18:47:34 +0100
Subject: [PATCH] chore: generalize embedRenderMessage

---
 src/Utils/TH.hs | 44 +++++++++++++++++++++++---------------------
 1 file changed, 23 insertions(+), 21 deletions(-)

diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs
index b218011d1..4e62ba2bc 100644
--- a/src/Utils/TH.hs
+++ b/src/Utils/TH.hs
@@ -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) []
       ]
     ]