Template and TH codegen via ghc-exactprint (#220)

and now only top-level function generations are left. * HsTemplate! * convert genTmplImplementation * TH code gen successful! * fix further * remove old functionSignature..
wavewave · Aug 12, 2023 · 671af5a · 671af5a
1 parent 67cbead
commit 671af5a
Show file tree

Hide file tree

Showing 10 changed files with 252 additions and 247 deletions.
diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs
@@ -197,13 +197,13 @@ simpleBuilder cfg sbc = do
   for_ tcms $ \m ->
     gen
       (tcmModule m <.> "Template" <.> "hs")
-      (prettyPrint (C.buildTemplateHs m))
+      (exactPrint (C.buildTemplateHs m))
   --
   putStrLn "Generating TH.hs"
   for_ tcms $ \m ->
     gen
       (tcmModule m <.> "TH" <.> "hs")
-      (prettyPrint (C.buildTHHs m))
+      (exactPrint (C.buildTHHs m))
   --
   -- TODO: Template.hs-boot need to be generated as well
   putStrLn "Generating hs-boot file"

diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs
@@ -4,7 +4,6 @@ module FFICXX.Generate.Code.HsCast
 
     -- * code
     castBody,
-    castBody_,
     genHsFrontInstCastable,
     genHsFrontInstCastableSelf,
   )
@@ -34,15 +33,7 @@ import FFICXX.Generate.Util.GHCExactPrint
     tyapp,
     tycon,
   )
-import qualified FFICXX.Generate.Util.HaskellSrcExts as O
-  ( app,
-    insDecl,
-    mkBind1,
-    mkPVar,
-    mkVar,
-  )
 import GHC.Hs (GhcPs)
-import qualified Language.Haskell.Exts.Syntax as O (InstDecl)
 import Language.Haskell.Syntax
   ( HsBind,
     HsDecl,
@@ -60,11 +51,6 @@ genImportInCast m =
 --
 -- code
 --
-castBody_ :: [O.InstDecl ()]
-castBody_ =
-  [ O.insDecl (O.mkBind1 "cast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "castPtr") (O.app (O.mkVar "get_fptr") (O.mkVar "x")))) Nothing),
-    O.insDecl (O.mkBind1 "uncast" [O.mkPVar "x", O.mkPVar "f"] (O.app (O.mkVar "f") (O.app (O.mkVar "cast_fptr_to_obj") (O.app (O.mkVar "castPtr") (O.mkVar "x")))) Nothing)
-  ]
 
 castBody :: [HsBind GhcPs]
 castBody =

diff --git a/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs b/fficxx/src/FFICXX/Generate/Code/HsImplementation.hs
@@ -24,7 +24,7 @@ import qualified Data.List as L (foldr1)
 import FFICXX.Generate.Code.Primitive
   ( accessorSignature,
     cxx2HsType,
-    functionSignature',
+    functionSignature,
     functionSignatureTMF,
     hsFuncXformer,
   )
@@ -132,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
+     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
+     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
+     in mkFun_ (aliasedFuncName c f) (functionSignature c f) [] rhs
 
 genHsFrontInstVariables :: Class -> [HsDecl GhcPs]
 genHsFrontInstVariables c =

diff --git a/fficxx/src/FFICXX/Generate/Code/HsInterface.hs b/fficxx/src/FFICXX/Generate/Code/HsInterface.hs
@@ -21,7 +21,7 @@ import qualified Data.List as L
 import qualified Data.List.NonEmpty as NE
 import FFICXX.Generate.Code.Primitive
   ( classConstraints,
-    functionSignature',
+    functionSignature,
   )
 import FFICXX.Generate.Dependency.Graph
   ( getCyclicDepSubmodules,
@@ -111,7 +111,7 @@ genHsFrontDecl isHsBoot c = do
   let cdecl = TyClD noExtField (mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body)
       -- for hs-boot, we only have instance head.
       cdecl' = TyClD noExtField (mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] [])
-      sigdecl f = mkFunSig (hsFuncName c f) (functionSignature' c f)
+      sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f)
       body = map sigdecl . virtualFuncs . class_funcs $ c
   if isHsBoot
     then return cdecl'

diff --git a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs
@@ -32,11 +32,12 @@ import Language.Haskell.Syntax
 
 hsClassRawType :: Class -> [HsDecl GhcPs]
 hsClassRawType c =
-  [ TyClD noExtField (mkData rawname [] []),
+  [ TyClD noExtField (mkData rawname [] [] []),
     TyClD
       noExtField
       ( mkNewtype
           highname
+          []
           (conDecl highname [tyapp tyPtr rawtype])
           deriv
       ),