move template member functions to HsImplementation

fficxx/src/FFICXX/Generate/Code/HsImplementation.hs

@@ -13,20 +13,29 @@ module FFICXX.Generate.Code.HsImplementation
     genHsFrontInstNonVirtual,
     genHsFrontInstStatic,
     genHsFrontInstVariables,
+
+    -- * template member functions
+    genTemplateMemberFunctions,
+    genTMFExp,
+    genTMFInstance,
   )
 where
 
 import Control.Monad.Reader (Reader)
+import qualified Data.List as L (foldr1)
 import FFICXX.Generate.Code.Primitive
   ( accessorSignature,
     cxx2HsType,
     functionSignature',
+    functionSignatureTMF,
     hsFuncXformer,
   )
 import FFICXX.Generate.Name
   ( accessorName,
     aliasedFuncName,
     hsFuncName,
+    hsTemplateMemberFunctionName,
+    hsTemplateMemberFunctionNameTH,
     hscAccessorName,
     hscFuncName,
     subModuleName,
@@ -36,14 +45,18 @@ import FFICXX.Generate.Type.Annotate (AnnotateMap)
 import FFICXX.Generate.Type.Class
   ( Accessor (..),
     Class (..),
+    TemplateMemberFunction (..),
     Types (..),
     isAbstractClass,
     isNewFunc,
     nonVirtualNotNewFuncs,
     staticFuncs,
     virtualFuncs,
   )
-import FFICXX.Generate.Type.Module (ClassModule (..))
+import FFICXX.Generate.Type.Module
+  ( ClassImportHeader (..),
+    ClassModule (..),
+  )
 import FFICXX.Generate.Util.GHCExactPrint
   ( app,
     cxEmpty,
@@ -54,7 +67,12 @@ import FFICXX.Generate.Util.GHCExactPrint
     mkInstance,
     mkVar,
   )
+import qualified FFICXX.Generate.Util.HaskellSrcExts as O hiding (app, doE, listE, qualStmt, strE)
+import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
+import qualified FFICXX.Runtime.CodeGen.Cxx as R
 import GHC.Hs (GhcPs)
+import qualified Language.Haskell.Exts.Build as O hiding (op)
+import qualified Language.Haskell.Exts.Syntax as O
 import Language.Haskell.Syntax (HsDecl, ImportDecl)
 
 --
@@ -117,3 +135,121 @@ genHsFrontInstVariables c =
             (mkVar (hscAccessorName c v accessor))
      in mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing
           <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing
+
+--
+-- Template Member Function
+--
+
+genTemplateMemberFunctions :: ClassImportHeader -> [O.Decl ()]
+genTemplateMemberFunctions cih =
+  let c = cihClass cih
+   in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c)
+
+-- TODO: combine this with genTmplInstance
+genTMFExp :: Class -> TemplateMemberFunction -> [O.Decl ()]
+genTMFExp c f = O.mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts)
+  where
+    nh = hsTemplateMemberFunctionNameTH c f
+    v = O.mkVar
+    p = O.mkPVar
+    itps = zip ([1 ..] :: [Int]) (tmf_params f)
+    tvars = map (\(i, _) -> "typ" ++ show i) itps
+    nparams = length itps
+    tparams = if nparams == 1 then O.tycon "Type" else O.tyTupleBoxed (replicate nparams (O.tycon "Type"))
+    sig = foldr1 O.tyfun [tparams, O.tycon "String", O.tyapp (O.tycon "Q") (O.tycon "Exp")]
+    tvars_p = if nparams == 1 then map p tvars else [O.pTuple (map p tvars)]
+    lit' = O.strE (hsTemplateMemberFunctionName c f <> "_")
+    lam = O.lamE [p "n"] (lit' `O.app` v "<>" `O.app` v "n")
+    rhs =
+      O.app (v "mkTFunc") $
+        let typs = if nparams == 1 then map v tvars else [O.tuple (map v tvars)]
+         in O.tuple (typs ++ [v "suffix", lam, v "tyf"])
+    sig' = functionSignatureTMF c f
+    tassgns = map (\(i, tp) -> O.pbind_ (p tp) (v "pure" `O.app` (v ("typ" ++ show i)))) itps
+    bstmts =
+      O.binds
+        [ O.mkBind1
+            "tyf"
+            [O.mkPVar "n"]
+            ( O.letE
+                tassgns
+                (O.bracketExp (O.typeBracket sig'))
+            )
+            Nothing
+        ]
+
+genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [O.Decl ()]
+genTMFInstance cih f =
+  O.mkFun
+    fname
+    sig
+    [p "isCprim", O.pTuple [p "qtyp", p "param"]]
+    rhs
+    Nothing
+  where
+    c = cihClass cih
+    fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f
+    p = O.mkPVar
+    v = O.mkVar
+    sig =
+      O.tycon "IsCPrimitive"
+        `O.tyfun` O.tyTupleBoxed [O.tycon "Q" `O.tyapp` O.tycon "Type", O.tycon "TemplateParamInfo"]
+        `O.tyfun` (O.tycon "Q" `O.tyapp` O.tylist (O.tycon "Dec"))
+    rhs = O.doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, O.letStmt lststmt, O.qualStmt retstmt]
+    suffixstmt = O.letStmt [O.pbind_ (p "suffix") (v "tpinfoSuffix" `O.app` v "param")]
+    qtypstmt = O.generator (p "typ") (v "qtyp")
+    genstmt =
+      O.generator
+        (p "f1")
+        ( v "mkMember"
+            `O.app` ( O.strE (hsTemplateMemberFunctionName c f <> "_")
+                        `O.app` v "<>"
+                        `O.app` v "suffix"
+                    )
+            `O.app` v (hsTemplateMemberFunctionNameTH c f)
+            `O.app` v "typ"
+            `O.app` v "suffix"
+        )
+    lststmt = [O.pbind_ (p "lst") (O.listE ([v "f1"]))]
+    retstmt = v "pure" `O.app` v "lst"
+    -- TODO: refactor out the following code.
+    foreignSrcStmt =
+      O.qualifier $
+        (v "addModFinalizer")
+          `O.app` ( v "addForeignSource"
+                      `O.app` O.con "LangCxx"
+                      `O.app` ( L.foldr1
+                                  (\x y -> O.inapp x (O.op "++") y)
+                                  [ includeStatic,
+                                    includeDynamic,
+                                    namespaceStr,
+                                    O.strE (hsTemplateMemberFunctionName c f),
+                                    O.strE "(",
+                                    v "suffix",
+                                    O.strE ")\n"
+                                  ]
+                              )
+                  )
+      where
+        includeStatic =
+          O.strE $
+            concatMap ((<> "\n") . R.renderCMacro . R.Include) $
+              [HdrName "MacroPatternMatch.h", cihSelfHeader cih]
+                <> cihIncludedHPkgHeadersInCPP cih
+                <> cihIncludedCPkgHeaders cih
+        includeDynamic =
+          O.letE
+            [ O.pbind_ (p "headers") (v "tpinfoCxxHeaders" `O.app` v "param"),
+              O.pbind_
+                (O.pApp (O.name "f") [p "x"])
+                (v "renderCMacro" `O.app` (O.con "Include" `O.app` v "x"))
+            ]
+            (v "concatMap" `O.app` v "f" `O.app` v "headers")
+        namespaceStr =
+          O.letE
+            [ O.pbind_ (p "nss") (v "tpinfoCxxNamespaces" `O.app` v "param"),
+              O.pbind_
+                (O.pApp (O.name "f") [p "x"])
+                (v "renderCStmt" `O.app` (O.con "UsingNamespace" `O.app` v "x"))
+            ]
+            (v "concatMap" `O.app` v "f" `O.app` v "nss")

fficxx/src/FFICXX/Generate/Code/HsTemplate.hs

@@ -2,10 +2,7 @@
 {-# LANGUAGE RecordWildCards #-}
 
 module FFICXX.Generate.Code.HsTemplate
-  ( genTemplateMemberFunctions,
-    genTMFExp,
-    genTMFInstance,
-    genImportInTemplate,
+  ( genImportInTemplate,
     genTmplInterface,
     genImportInTH,
     genTmplImplementation,
@@ -22,16 +19,13 @@ import FFICXX.Generate.Code.Cpp
 import FFICXX.Generate.Code.HsCast (castBody_)
 import FFICXX.Generate.Code.Primitive
   ( functionSignatureT,
-    functionSignatureTMF,
     functionSignatureTT,
     tmplAccessorToTFun,
   )
 import FFICXX.Generate.Dependency (calculateDependency)
 import FFICXX.Generate.Name
   ( ffiTmplFuncName,
     hsTemplateClassName,
-    hsTemplateMemberFunctionName,
-    hsTemplateMemberFunctionNameTH,
     hsTmplFuncName,
     hsTmplFuncNameTH,
     subModuleName,
@@ -41,16 +35,13 @@ import FFICXX.Generate.Name
 import FFICXX.Generate.Type.Class
   ( Accessor (Getter, Setter),
     Arg (..),
-    Class (..),
     TemplateClass (..),
     TemplateFunction (..),
-    TemplateMemberFunction (..),
     Types (Void),
     Variable (..),
   )
 import FFICXX.Generate.Type.Module
-  ( ClassImportHeader (..),
-    TemplateClassImportHeader (..),
+  ( TemplateClassImportHeader (..),
     TemplateClassSubmoduleType (..),
   )
 import FFICXX.Generate.Util.HaskellSrcExts
@@ -114,132 +105,22 @@ import Language.Haskell.Exts.Syntax
     ImportDecl,
   )
 
-------------------------------
--- Template member function --
-------------------------------
-
-genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()]
-genTemplateMemberFunctions cih =
-  let c = cihClass cih
-   in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c)
-
--- TODO: combine this with genTmplInstance
-genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()]
-genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts)
-  where
-    nh = hsTemplateMemberFunctionNameTH c f
-    v = mkVar
-    p = mkPVar
-    itps = zip ([1 ..] :: [Int]) (tmf_params f)
-    tvars = map (\(i, _) -> "typ" ++ show i) itps
-    nparams = length itps
-    tparams = if nparams == 1 then tycon "Type" else tyTupleBoxed (replicate nparams (tycon "Type"))
-    sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")]
-    tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)]
-    lit' = strE (hsTemplateMemberFunctionName c f <> "_")
-    lam = lamE [p "n"] (lit' `app` v "<>" `app` v "n")
-    rhs =
-      app (v "mkTFunc") $
-        let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)]
-         in tuple (typs ++ [v "suffix", lam, v "tyf"])
-    sig' = functionSignatureTMF c f
-    tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps
-    bstmts =
-      binds
-        [ mkBind1
-            "tyf"
-            [mkPVar "n"]
-            ( letE
-                tassgns
-                (bracketExp (typeBracket sig'))
-            )
-            Nothing
-        ]
-
-genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [Decl ()]
-genTMFInstance cih f =
-  mkFun
-    fname
-    sig
-    [p "isCprim", pTuple [p "qtyp", p "param"]]
-    rhs
-    Nothing
-  where
-    c = cihClass cih
-    fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f
-    p = mkPVar
-    v = mkVar
-    sig =
-      tycon "IsCPrimitive"
-        `tyfun` tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]
-        `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec"))
-    rhs = doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, letStmt lststmt, qualStmt retstmt]
-    suffixstmt = letStmt [pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param")]
-    qtypstmt = generator (p "typ") (v "qtyp")
-    genstmt =
-      generator
-        (p "f1")
-        ( v "mkMember"
-            `app` ( strE (hsTemplateMemberFunctionName c f <> "_")
-                      `app` v "<>"
-                      `app` v "suffix"
-                  )
-            `app` v (hsTemplateMemberFunctionNameTH c f)
-            `app` v "typ"
-            `app` v "suffix"
-        )
-    lststmt = [pbind_ (p "lst") (listE ([v "f1"]))]
-    retstmt = v "pure" `app` v "lst"
-    -- TODO: refactor out the following code.
-    foreignSrcStmt =
-      qualifier $
-        (v "addModFinalizer")
-          `app` ( v "addForeignSource"
-                    `app` con "LangCxx"
-                    `app` ( L.foldr1
-                              (\x y -> inapp x (op "++") y)
-                              [ includeStatic,
-                                includeDynamic,
-                                namespaceStr,
-                                strE (hsTemplateMemberFunctionName c f),
-                                strE "(",
-                                v "suffix",
-                                strE ")\n"
-                              ]
-                          )
-                )
-      where
-        includeStatic =
-          strE $
-            concatMap ((<> "\n") . R.renderCMacro . R.Include) $
-              [HdrName "MacroPatternMatch.h", cihSelfHeader cih]
-                <> cihIncludedHPkgHeadersInCPP cih
-                <> cihIncludedCPkgHeaders cih
-        includeDynamic =
-          letE
-            [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param"),
-              pbind_
-                (pApp (name "f") [p "x"])
-                (v "renderCMacro" `app` (con "Include" `app` v "x"))
-            ]
-            (v "concatMap" `app` v "f" `app` v "headers")
-        namespaceStr =
-          letE
-            [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param"),
-              pbind_
-                (pApp (name "f") [p "x"])
-                (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x"))
-            ]
-            (v "concatMap" `app` v "f" `app` v "nss")
-
---------------------
--- Template Class --
---------------------
+--
+-- imports
+--
 
 genImportInTemplate :: TemplateClass -> [ImportDecl ()]
 genImportInTemplate t0 =
   fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTemplate, t0)
 
+genImportInTH :: TemplateClass -> [ImportDecl ()]
+genImportInTH t0 =
+  fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0)
+
+--
+-- interface
+--
+
 genTmplInterface :: TemplateClass -> [Decl ()]
 genTmplInterface t =
   [ mkData rname (map mkTBind tps) [] Nothing,
@@ -271,9 +152,9 @@ genTmplInterface t =
         insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing)
       ]
 
-genImportInTH :: TemplateClass -> [ImportDecl ()]
-genImportInTH t0 =
-  fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0)
+--
+-- implementation
+--
 
 genTmplImplementation :: TemplateClass -> [Decl ()]
 genTmplImplementation t =