RawType code generation via ghc-exactprint (#215)

Separated out HsRawType out of HsFrontend. implemented mkData, mkNewtype, mkDeriving etc. so that RawType can be generated and tested. * separate out HsRawType * mkData, mkNewtype. HsRawType is almost converted. * now no missing part in HsRawType * mkDeriving * mkTypeFamInst * generated code formatting correctly. now it works! * ormolu
wavewave · Aug 10, 2023 · 086e022 · 086e022
1 parent 83f70dc
commit 086e022
Show file tree

Hide file tree

Showing 8 changed files with 288 additions and 102 deletions.
diff --git a/experiments/sample.hs b/experiments/sample.hs
@@ -10,4 +10,7 @@ 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)
diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal
@@ -59,6 +59,7 @@ Library
                FFICXX.Generate.Code.HsFFI
                FFICXX.Generate.Code.HsFrontEnd
                FFICXX.Generate.Code.HsProxy
+               FFICXX.Generate.Code.HsRawType
                FFICXX.Generate.Code.HsTemplate
                FFICXX.Generate.Code.Cabal
                FFICXX.Generate.Code.Primitive

diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs
@@ -157,10 +157,11 @@ simpleBuilder cfg sbc = do
   for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt)
   --
   putStrLn "Generating RawType.hs"
-  for_ mods $ \m ->
+  for_ mods $ \m -> do
+    debugExactPrint (C.buildRawTypeHs m)
     gen
       (cmModule m <.> "RawType" <.> "hs")
-      (prettyPrint (C.buildRawTypeHs m))
+      (exactPrint (C.buildRawTypeHs m))
   --
   putStrLn "Generating FFI.hsc"
   for_ mods $ \m ->

diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs
@@ -18,8 +18,6 @@ import FFICXX.Generate.Util.GHCExactPrint
     tyapp,
     tycon,
   )
---
-
 import qualified FFICXX.Generate.Util.HaskellSrcExts as O
   ( app,
     classA,
@@ -96,12 +94,20 @@ genHsFrontInstCastable c
           (_, rname) = hsClassName c
           a = mkTVar "a"
           ctxt = cxTuple [classA iname [a], classA "FPtr" [a]]
-       in Just (instD (mkInstance ctxt "Castable" [a, tyapp tyPtr (tycon rname)] castBody))
+       in Just (instD (mkInstance ctxt "Castable" [a, tyapp tyPtr (tycon rname)] [] castBody))
   | otherwise = Nothing
 
 genHsFrontInstCastableSelf :: Class -> Maybe (HsDecl GhcPs)
 genHsFrontInstCastableSelf c
   | (not . isAbstractClass) c =
       let (cname, rname) = hsClassName c
-       in Just (instD (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody))
+       in Just $
+            instD
+              ( mkInstance
+                  cxEmpty
+                  "Castable"
+                  [tycon cname, tyapp tyPtr (tycon rname)]
+                  []
+                  castBody
+              )
   | otherwise = Nothing
diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs
@@ -189,29 +189,6 @@ genHsFrontInstVariables c =
 
 --------------------------
 
-hsClassRawType :: Class -> [Decl ()]
-hsClassRawType c =
-  [ mkData rawname [] [] Nothing,
-    mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv,
-    mkInstance
-      cxEmpty
-      "FPtr"
-      [hightype]
-      [ insType (tyapp (tycon "Raw") hightype) rawtype,
-        insDecl (mkBind1 "get_fptr" [pApp (name highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing),
-        insDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing)
-      ]
-  ]
-  where
-    (highname, rawname) = hsClassName c
-    hightype = tycon highname
-    rawtype = tycon rawname
-    mderiv = Just (mkDeriving [i_eq, i_ord, i_show])
-      where
-        i_eq = irule Nothing Nothing (ihcon (unqual "Eq"))
-        i_ord = irule Nothing Nothing (ihcon (unqual "Ord"))
-        i_show = irule Nothing Nothing (ihcon (unqual "Show"))
-
 ------------
 -- upcast --
 ------------

diff --git a/fficxx/src/FFICXX/Generate/Code/HsRawType.hs b/fficxx/src/FFICXX/Generate/Code/HsRawType.hs
@@ -0,0 +1,62 @@
+module FFICXX.Generate.Code.HsRawType
+  ( hsClassRawType,
+  )
+where
+
+import FFICXX.Generate.Name (hsClassName)
+import FFICXX.Generate.Type.Class (Class (..))
+import FFICXX.Generate.Util.GHCExactPrint
+  ( con,
+    conDecl,
+    cxEmpty,
+    instD,
+    mkBind1,
+    mkData,
+    mkDeriving,
+    mkInstance,
+    mkNewtype,
+    mkPVar,
+    mkTypeFamInst,
+    mkVar,
+    pApp,
+    parP,
+    tyPtr,
+    tyapp,
+    tycon,
+  )
+import GHC.Hs (GhcPs)
+import Language.Haskell.Syntax
+  ( HsDecl (TyClD),
+    noExtField,
+  )
+
+hsClassRawType :: Class -> [HsDecl GhcPs]
+hsClassRawType c =
+  [ TyClD noExtField (mkData rawname [] []),
+    TyClD
+      noExtField
+      ( mkNewtype
+          highname
+          (conDecl highname [tyapp tyPtr rawtype])
+          deriv
+      ),
+    instD $
+      mkInstance
+        cxEmpty
+        "FPtr"
+        [hightype]
+        [ mkTypeFamInst "Raw" [hightype] rawtype
+        ]
+        [ mkBind1
+            "get_fptr"
+            [parP (pApp highname [mkPVar "ptr"])]
+            (mkVar "ptr")
+            Nothing,
+          mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing
+        ]
+  ]
+  where
+    (highname, rawname) = hsClassName c
+    hightype = tycon highname
+    rawtype = tycon rawname
+    deriv = mkDeriving [tycon "Eq", tycon "Ord", tycon "Show"]
diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs
@@ -36,7 +36,6 @@ import FFICXX.Generate.Code.HsCast
 import FFICXX.Generate.Code.HsFFI
   ( genHsFFI,
     genImportInFFI,
-    genTopLevelFFI,
     genTopLevelFFI_,
   )
 import FFICXX.Generate.Code.HsFrontEnd
@@ -59,9 +58,9 @@ import FFICXX.Generate.Code.HsFrontEnd
     genImportInModule,
     genImportInTopLevel,
     genTopLevelDef,
-    hsClassRawType,
   )
 import FFICXX.Generate.Code.HsProxy (genProxyInstance)
+import FFICXX.Generate.Code.HsRawType (hsClassRawType)
 import FFICXX.Generate.Code.HsTemplate
   ( genImportInTH,
     genImportInTemplate,
@@ -355,27 +354,25 @@ buildFFIHsc m =
         <> genExtraImport m
     hscBody = fmap (ForD noExtField) (genHsFFI (cmCIH m))
 
-buildRawTypeHs :: ClassModule -> Module ()
+buildRawTypeHs :: ClassModule -> HsModule GhcPs
 buildRawTypeHs m =
-  mkModule
+  Ex.mkModule
     (cmModule m <.> "RawType")
-    [ lang
-        [ "ForeignFunctionInterface",
-          "TypeFamilies",
-          "MultiParamTypeClasses",
-          "FlexibleInstances",
-          "TypeSynonymInstances",
-          "EmptyDataDecls",
-          "ExistentialQuantification",
-          "ScopedTypeVariables"
-        ]
+    [ "ForeignFunctionInterface",
+      "TypeFamilies",
+      "MultiParamTypeClasses",
+      "FlexibleInstances",
+      "TypeSynonymInstances",
+      "EmptyDataDecls",
+      "ExistentialQuantification",
+      "ScopedTypeVariables"
     ]
     rawtypeImports
     rawtypeBody
   where
     rawtypeImports =
-      [ mkImport "Foreign.Ptr",
-        mkImport "FFICXX.Runtime.Cast"
+      [ Ex.mkImport "Foreign.Ptr",
+        Ex.mkImport "FFICXX.Runtime.Cast"
       ]
     rawtypeBody =
       let c = cihClass (cmCIH m)