Template member function codegen via ghc-exactprint (#219)

* implement tyTupleBoxed, pTuple, lamE, tupleE, bracketExp, typeBracket
* now genTMFExp is converted modulo functionSignatureTMF'
* implement cxx2hsType4Tmpl (old convertCpp2HS4Tmpl) and functionSignatureTMF
* now genTMFExp is fully implemented.
* finally, TMF function gen is implemented!
* mkBindStmt
* mkLetStmt
* template member function generated code works!
* simple test script. add hspec-discover to the devshell dep

experiments/sample.hs

@@ -1,16 +1,8 @@
 {-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -w #-}
 
 module MyModule where
 
-data K = K Int
-
-test :: IO ()
-test = do
-  addModFinalizer (addForeignSource LangCxx "\n#include \"test\"")
-
-instance (C a) => D (P a) (Q a) where
-  type F (P a) = Double
-  dinst x = x * x
-
-newtype Loader = Loader (Ptr RawLoader) deriving (Eq, Ord, Show)
+f :: Double -> Double
+f x = [1, 2]

fficxx/src/FFICXX/Generate/Builder.hs

@@ -181,8 +181,7 @@ simpleBuilder cfg sbc = do
       (exactPrint (C.buildCastHs m))
   --
   putStrLn "Generating Implementation.hs"
-  for_ mods $ \m -> do
-    debugExactPrint (C.buildImplementationHs mempty m)
+  for_ mods $ \m ->
     gen
       (cmModule m <.> "Implementation" <.> "hs")
       (exactPrint (C.buildImplementationHs mempty m))

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

@@ -23,7 +23,7 @@ import FFICXX.Generate.Util.GHCExactPrint
     cxEmpty,
     cxTuple,
     instD,
-    mkBind1,
+    mkBind1_,
     mkImport,
     mkInstance,
     mkPVar,
@@ -68,7 +68,7 @@ castBody_ =
 
 castBody :: [HsBind GhcPs]
 castBody =
-  [ mkBind1
+  [ mkBind1_
       "cast"
       [mkPVar "x", mkPVar "f"]
       ( app
@@ -84,9 +84,8 @@ castBody =
                   )
               )
           )
-      )
-      Nothing,
-    mkBind1
+      ),
+    mkBind1_
       "uncast"
       [mkPVar "x", mkPVar "f"]
       ( app
@@ -103,7 +102,6 @@ castBody =
               )
           )
       )
-      Nothing
   ]
 
 genHsFrontInstCastable :: Class -> Maybe (HsDecl GhcPs)

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

@@ -16,8 +16,6 @@ module FFICXX.Generate.Code.HsImplementation
 
     -- * template member functions
     genTemplateMemberFunctions,
-    genTMFExp,
-    genTMFInstance,
   )
 where
 
@@ -59,20 +57,44 @@ import FFICXX.Generate.Type.Module
   )
 import FFICXX.Generate.Util.GHCExactPrint
   ( app,
+    bracketExp,
+    con,
     cxEmpty,
+    doE,
+    inapp,
     instD,
-    mkBind1,
+    lamE,
+    letE,
+    listE,
+    mkBind1_,
+    mkBindStmt,
+    mkBodyStmt,
     mkFun,
+    mkFun_,
     mkImport,
     mkInstance,
+    mkLetStmt,
+    mkPVar,
     mkVar,
+    op,
+    pApp,
+    pTuple,
+    par,
+    pbind_,
+    strE,
+    toLocalBinds,
+    tupleE,
+    tyTupleBoxed,
+    tyapp,
+    tycon,
+    tyfun,
+    tylist,
+    typeBracket,
+    valBinds,
   )
-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)
 
 --
@@ -91,7 +113,7 @@ genHsFrontInst :: Class -> Class -> [HsDecl GhcPs]
 genHsFrontInst parent child
   | (not . isAbstractClass) child =
       let idecl = mkInstance cxEmpty (typeclassName parent) [cxx2HsType (Just child) SelfType] [] body
-          defn f = mkBind1 (hsFuncName child f) [] rhs Nothing
+          defn f = mkBind1_ (hsFuncName child f) [] rhs
             where
               rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))
           body = map defn . virtualFuncs . class_funcs $ parent
@@ -110,21 +132,21 @@ genHsFrontInstNew c = do
         -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap
         -- newfuncann = mkComment 0 cann
         rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
-     in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing
+     in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs
 
 genHsFrontInstNonVirtual :: Class -> [HsDecl GhcPs]
 genHsFrontInstNonVirtual c =
   flip concatMap nonvirtualFuncs $ \f ->
     let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
-     in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing
+     in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs
   where
     nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c)
 
 genHsFrontInstStatic :: Class -> [HsDecl GhcPs]
 genHsFrontInstStatic c =
   flip concatMap (staticFuncs (class_funcs c)) $ \f ->
     let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
-     in mkFun (aliasedFuncName c f) (functionSignature' c f) [] rhs Nothing
+     in mkFun_ (aliasedFuncName c f) (functionSignature' c f) [] rhs
 
 genHsFrontInstVariables :: Class -> [HsDecl GhcPs]
 genHsFrontInstVariables c =
@@ -133,123 +155,149 @@ genHsFrontInstVariables c =
           app
             (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1"))
             (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
+     in mkFun_ (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter)
+          <> mkFun_ (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter)
 
 --
 -- Template Member Function
 --
 
-genTemplateMemberFunctions :: ClassImportHeader -> [O.Decl ()]
+genTemplateMemberFunctions :: ClassImportHeader -> [HsDecl GhcPs]
 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)
+genTMFExp :: Class -> TemplateMemberFunction -> [HsDecl GhcPs]
+genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs bstmts
   where
     nh = hsTemplateMemberFunctionNameTH c f
-    v = O.mkVar
-    p = O.mkPVar
+    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 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")
+    tparams
+      | nparams == 1 = tycon "Type"
+      | otherwise = tyTupleBoxed (replicate nparams (tycon "Type"))
+    sig = foldr1 tyfun [tparams, tycon "String", tyapp (tycon "Q") (tycon "Exp")]
+    tvars_p
+      | nparams == 1 = fmap p tvars
+      | otherwise = [pTuple (fmap p tvars)]
+    lit' = strE (hsTemplateMemberFunctionName c f <> "_")
+    lam = lamE [p "n"] (lit' `app` v "<>" `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"])
+      app (v "mkTFunc") $
+        let typs
+              | nparams == 1 = fmap v tvars
+              | otherwise = [tupleE (map v tvars)]
+         in tupleE (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
+    tassgns =
+      fmap
+        (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i))))
+        itps
     bstmts =
-      O.binds
-        [ O.mkBind1
-            "tyf"
-            [O.mkPVar "n"]
-            ( O.letE
-                tassgns
-                (O.bracketExp (O.typeBracket sig'))
-            )
-            Nothing
-        ]
+      toLocalBinds True $
+        valBinds
+          [ mkBind1_
+              "tyf"
+              [mkPVar "n"]
+              ( letE
+                  (toLocalBinds False (valBinds tassgns))
+                  (bracketExp (typeBracket sig'))
+              )
+          ]
 
-genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [O.Decl ()]
+genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [HsDecl GhcPs]
 genTMFInstance cih f =
-  O.mkFun
+  mkFun_
     fname
     sig
-    [p "isCprim", O.pTuple [p "qtyp", p "param"]]
+    [p "isCprim", pTuple [p "qtyp", p "param"]]
     rhs
-    Nothing
   where
     c = cihClass cih
     fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f
-    p = O.mkPVar
-    v = O.mkVar
+    p = mkPVar
+    v = 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")
+      tycon "IsCPrimitive"
+        `tyfun` tyTupleBoxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]
+        `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec"))
+    rhs =
+      doE
+        [ suffixstmt,
+          qtypstmt,
+          genstmt,
+          foreignSrcStmt,
+          mkLetStmt lststmt,
+          mkBodyStmt retstmt
+        ]
+    suffixstmt =
+      mkLetStmt [pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param")]
+    qtypstmt =
+      mkBindStmt (p "typ") (v "qtyp")
     genstmt =
-      O.generator
+      mkBindStmt
         (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"
+            `app` par
+              ( strE (hsTemplateMemberFunctionName c f <> "_")
+                  `app` v "<>"
+                  `app` v "suffix"
+              )
+            `app` v (hsTemplateMemberFunctionNameTH c f)
+            `app` v "typ"
+            `app` v "suffix"
         )
-    lststmt = [O.pbind_ (p "lst") (O.listE ([v "f1"]))]
-    retstmt = v "pure" `O.app` v "lst"
+
+    lststmt = [pbind_ (p "lst") (listE ([v "f1"]))]
+    retstmt = v "pure" `app` v "lst"
     -- TODO: refactor out the following code.
     foreignSrcStmt =
-      O.qualifier $
+      mkBodyStmt $
         (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"
-                                  ]
-                              )
+          `app` par
+            ( v "addForeignSource"
+                `app` con "LangCxx"
+                `app` par
+                  ( L.foldr1
+                      (\x y -> inapp x (op "++") y)
+                      [ par includeStatic,
+                        par includeDynamic,
+                        par namespaceStr,
+                        strE (hsTemplateMemberFunctionName c f),
+                        strE "(",
+                        v "suffix",
+                        strE ")\n"
+                      ]
                   )
+            )
       where
         includeStatic =
-          O.strE $
+          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")
+          letE
+            ( toLocalBinds False . valBinds $
+                [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param"),
+                  pbind_
+                    (pApp "f" [p "x"])
+                    (v "renderCMacro" `app` par (con "Include" `app` v "x"))
+                ]
+            )
+            (v "concatMap" `app` v "f" `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")
+          letE
+            ( toLocalBinds False . valBinds $
+                [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param"),
+                  pbind_
+                    (pApp "f" [p "x"])
+                    (v "renderCStmt" `app` par (con "UsingNamespace" `app` v "x"))
+                ]
+            )
+            (v "concatMap" `app` v "f" `app` v "nss")