TemplateHaskell-generated smart constructors about fused-effects HOT 11 CLOSED

@@ -38,6 +34,7 @@ import Data.Char (toLower)
 import Data.List ((\\), nub)
 import Language.Haskell.TH
 import Language.Haskell.TH.Syntax
+import Generics.SYB

 #if !(MIN_VERSION_base(4,8,0))
 import Control.Applicative
@@ -191,13 +188,19 @@ extractVars (ParensT x) = extractVars x
 extractVars _ = []

 liftCon' :: Bool -> [TyVarBndr] -> Cxt -> Type -> Type -> [Type] -> Name -> [Type] -> Q [Dec]
-liftCon' typeSig tvbs cx f n ns cn ts = do
+liftCon' typeSig tvbs cx f n nns cn tts = do
   -- prepare some names
   opName <- mkName <$> mkOpName (nameBase cn)
-  m      <- newName "m"
+  r      <- newName "r"
   a      <- newName "a"
-  monadFree <- findTypeOrFail  "MonadFree"
-  liftF     <- findValueOrFail "liftF"
+  semantic <- findTypeOrFail  "Semantic"
+  member   <- findTypeOrFail  "Member"
+  liftF    <- findValueOrFail "send"
+  let m = last nns
+      ns = init nns
+      replaceMType t | t == m = ConT semantic `AppT` VarT r
+                     | otherwise = t
+      ts = everywhere (mkT replaceMType) tts
   -- look at the constructor parameters
   args <- mapM (mkArg n) ts
   let ps = params args    -- these are not using type parameter
@@ -205,26 +208,28 @@ liftCon' typeSig tvbs cx f n ns cn ts = do
   -- based on cs we get return type and refined expressions
   -- (e.g. with Nothing/Just or Left/Right tags)
   (retType, es) <- unifyCaptured a cs
-  -- operation type is (a1 -> a2 -> ... -> aN -> m r)
-  let opType  = foldr (AppT . AppT ArrowT) (AppT (VarT m) retType) ps
+  -- operation type is (a1 -> a2 -> ... -> aN -> Semantic r z)
+  let opType  = foldr (AppT . AppT ArrowT) (ConT semantic `AppT` VarT r `AppT` retType) ps
   -- picking names for the implementation
   xs  <- mapM (const $ newName "p") ps
   let pat  = map VarP xs                      -- this is LHS
       exprs = zipExprs (map VarE xs) es args  -- this is what ctor would be applied to
       fval = foldl AppE (ConE cn) exprs       -- this is RHS without liftF
       ns' = nub (concatMap extractVars ns)
-      q = filter nonNext tvbs ++ map PlainTV (qa ++ m : ns')
+      q = filter nonNext tvbs ++ map PlainTV (qa ++ r : ns')
       qa = case retType of VarT b | a == b -> [a]; _ -> []
       f' = foldl AppT f ns
   return $ concat
     [ if typeSig
 #if MIN_VERSION_template_haskell(2,10,0)
-        then [ SigD opName (ForallT q (cx ++ [ConT monadFree `AppT` f' `AppT` VarT m]) opType) ]
+        then [ SigD opName (ForallT q (cx ++ [ConT member `AppT` f' `AppT` VarT r]) opType) ]
 #else
-        then [ SigD opName (ForallT q (cx ++ [ClassP monadFree [f', VarT m]]) opType) ]
+        then [ SigD opName (ForallT q (cx ++ [ClassP member [f', VarT r]]) opType) ]
 #endif
         else []
-    , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ] ] ]
+    , [ FunD opName [ Clause pat (NormalB $ AppE (VarE liftF) fval) [] ]
+      , PragmaD $ InlineP opName Inline FunLike AllPhases
+      ] ]
   where
     nonNext (PlainTV pn) = VarT pn /= n
     nonNext (KindedTV kn _) = VarT kn /= n