Start migrating to direct GHC API use and ghc-exactprint (#212)

The simplest HsProxy is migrated. For the time being, haskell-src-exts and ghc+ghc-exactprint will coexist and haskell-src-exts will be faded away. * prepare for ghc-exactprint migration. use only Util.HaskellSrcExts functions except types. * explicit export * make proxy-test generatable (for temporary tests for ghc-exactprint codegen) * first try to generate code using ghc-exactprint * finally print as desired. * success in LANGUAGE pragma printing * mkImport implementation * mkFun, mkFunSig * further mkBind1 * correct indentation doE and handling empty list * remove all s1 * con, inapp, op, par, strE * ormolu format fix * ghc945 -> ghc962 in CI
wavewave · Aug 8, 2023 · cce2332 · cce2332
1 parent 52f371d
commit cce2332
Show file tree

Hide file tree

Showing 18 changed files with 1,127 additions and 126 deletions.
diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml
@@ -20,7 +20,7 @@ jobs:
         nix build --print-build-logs .#ghc962.fficxx-runtime
     - name: build fficxx (GHC 9.6.2)
       run: |
-        nix build --print-build-logs .#ghc945.fficxx
+        nix build --print-build-logs .#ghc962.fficxx
     - name: build stdcxx (GHC 9.6.2)
       run: |
         nix build --print-build-logs .#ghc962.stdcxx

diff --git a/examples/proxy/Gen.hs b/examples/proxy/Gen.hs
@@ -45,7 +45,8 @@ import FFICXX.Generate.Type.Class
     Class (..),
     Function (..),
     ProtectedMethod (..),
-    TopLevelFunction (..),
+    TLOrdinary (..),
+    TopLevel (..),
     Variable (..),
   )
 import FFICXX.Generate.Type.Config
@@ -69,7 +70,7 @@ stdcxx_cabal :: Cabal
 stdcxx_cabal =
   Cabal
     { cabal_pkgname = CabalName "stdcxx",
-      cabal_version = "0.7.0.1",
+      cabal_version = "0.8",
       cabal_cheaderprefix = "STD",
       cabal_moduleprefix = "STD",
       cabal_additional_c_incs = [],
@@ -98,54 +99,6 @@ deletable =
       class_tmpl_funcs = []
     }
 
--- import from stdcxx
-string :: Class
-string =
-  Class
-    stdcxx_cabal
-    "string"
-    [deletable]
-    mempty
-    (Just (ClassAlias {caHaskellName = "CppString", caFFIName = "string"}))
-    [ Constructor [cstring "p"] Nothing,
-      NonVirtual cstring_ "c_str" [] Nothing,
-      NonVirtual (cppclassref_ string) "append" [cppclassref string "str"] Nothing,
-      NonVirtual (cppclassref_ string) "erase" [] Nothing
-    ]
-    []
-    []
-    False
-
-t_vector :: TemplateClass
-t_vector =
-  TmplCls
-    stdcxx_cabal
-    "Vector"
-    "std::vector"
-    ["tp1"]
-    [ TFunNew [] Nothing,
-      TFun void_ "push_back" "push_back" [Arg (TemplateParam "tp1") "x"] Nothing,
-      TFun void_ "pop_back" "pop_back" [] Nothing,
-      TFun (TemplateParam "tp1") "at" "at" [int "n"] Nothing,
-      TFun int_ "size" "size" [] Nothing,
-      TFunDelete
-    ]
-
-t_unique_ptr :: TemplateClass
-t_unique_ptr =
-  TmplCls
-    stdcxx_cabal
-    "UniquePtr"
-    "std::unique_ptr"
-    ["tp1"]
-    [ TFunNew [] (Just "newUniquePtr0"),
-      TFunNew [Arg (TemplateParamPointer "tp1") "p"] Nothing,
-      TFun (TemplateParamPointer "tp1") "get" "get" [] Nothing,
-      TFun (TemplateParamPointer "tp1") "release" "release" [] Nothing,
-      TFun void_ "reset" "reset" [] Nothing,
-      TFunDelete
-    ]
-
 -- -------------------------------------------------------------------
 -- proxy-test
 -- -------------------------------------------------------------------
@@ -218,7 +171,7 @@ main = do
   let tmpldir =
         if length args == 1
           then args !! 0
-          else "../template"
+          else "./template"
 
   cwd <- getCurrentDirectory
 

diff --git a/examples/proxy/cabal.project b/examples/proxy/cabal.project
@@ -0,0 +1,6 @@
+packages:
+  ../../fficxx/
+  ../../fficxx-runtime/
+optional-packages:
+  ./stdcxx/
+  ./proxy-test/
diff --git a/experiments/ghc-exactprint.hs b/experiments/ghc-exactprint.hs
@@ -0,0 +1,14 @@
+module Main where
+
+import Language.Haskell.GHC.ExactPrint
+  ( makeDeltaAst,
+    parseModule,
+    showAst,
+  )
+
+main :: IO ()
+main = do
+  e <- parseModule "/nix/store/1dccaqdx3v2acc4zk5cnln14jf5q7h04-ghc-9.6.2-with-packages/lib/ghc-9.6.2/lib" "./sample.hs"
+  case e of
+    Left msg -> print "error" -- print msg
+    Right parsed -> putStrLn (showAst (makeDeltaAst parsed))
diff --git a/experiments/sample.hs b/experiments/sample.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# OPTIONS_GHC -w #-}
+
+module MyModule where
+
+data K = K Int
+
+test :: IO ()
+test = do
+  addModFinalizer (addForeignSource LangCxx "\n#include \"test\"")
diff --git a/fficxx/LICENSE b/fficxx/LICENSE
@@ -1,7 +1,7 @@
 The following license covers this documentation, and the source code, except
 where otherwise indicated.
 
-Copyright 2011-2022, Ian-Woo Kim. All rights reserved.
+Copyright 2011-2023, Ian-Woo Kim. All rights reserved.
 
 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are met:

diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal
@@ -1,4 +1,4 @@
-Cabal-Version:  3.0
+Cabal-Version:  3.6
 Name:           fficxx
 Version:        0.8.0.0
 Synopsis:       Automatic C++ binding generation
@@ -31,7 +31,6 @@ Library
                , fficxx-runtime
                , filepath>1
                , hashable
-               , haskell-src-exts >= 1.22
                , lens > 3
                , mtl>2
                , process
@@ -42,6 +41,16 @@ Library
                , template-haskell
                , text
                , unordered-containers
+               , haskell-src-exts
+  if impl (ghc >= 9.6)
+    Build-Depends:
+      ghc >= 9.6,
+      ghc-exactprint >= 1.7.0.0
+  else
+    Build-Depends:
+      ghc,
+      ghc-exactprint
+
   Exposed-Modules:
                FFICXX.Generate.Builder
                FFICXX.Generate.Config
@@ -60,6 +69,7 @@ Library
                FFICXX.Generate.QQ.Verbatim
                FFICXX.Generate.Util
                FFICXX.Generate.Util.DepGraph
+               FFICXX.Generate.Util.GHCExactPrint
                FFICXX.Generate.Util.HaskellSrcExts
                FFICXX.Generate.Type.Annotate
                FFICXX.Generate.Type.Cabal

diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs
@@ -40,8 +40,10 @@ import FFICXX.Generate.Type.Module
     TopLevelImportHeader (..),
   )
 import FFICXX.Generate.Util (moduleDirFile)
+import FFICXX.Generate.Util.GHCExactPrint (exactPrint)
+import FFICXX.Generate.Util.HaskellSrcExts (prettyPrint)
 import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
-import Language.Haskell.Exts.Pretty (prettyPrint)
+import qualified Language.Haskell.GHC.ExactPrint as Exact
 import System.Directory
   ( copyFile,
     createDirectoryIfMissing,
@@ -163,8 +165,13 @@ simpleBuilder cfg sbc = do
   --
   putStrLn "Generating Proxy.hs"
   for_ mods $ \m ->
-    when (hasProxy . cihClass . cmCIH $ m) $
-      gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (C.buildProxyHs m))
+    when (hasProxy . cihClass . cmCIH $ m) $ do
+      let x = C.buildProxyHs m
+      putStrLn (Exact.showAst x)
+      putStrLn "-------"
+      putStrLn (exactPrint (C.buildProxyHs m))
+      putStrLn "-------"
+      gen (cmModule m <.> "Proxy" <.> "hs") (exactPrint (C.buildProxyHs m))
   --
   putStrLn "Generating Template.hs"
   for_ tcms $ \m ->

diff --git a/fficxx/src/FFICXX/Generate/Code/HsCast.hs b/fficxx/src/FFICXX/Generate/Code/HsCast.hs
@@ -4,7 +4,8 @@ module FFICXX.Generate.Code.HsCast where
 import FFICXX.Generate.Name (hsClassName, typeclassName)
 import FFICXX.Generate.Type.Class (Class (..), isAbstractClass)
 import FFICXX.Generate.Util.HaskellSrcExts
-  ( classA,
+  ( app,
+    classA,
     cxEmpty,
     cxTuple,
     insDecl,
@@ -18,8 +19,7 @@ import FFICXX.Generate.Util.HaskellSrcExts
     tycon,
     unqual,
   )
-import Language.Haskell.Exts.Build (app)
-import Language.Haskell.Exts.Syntax (Decl (..), InstDecl (..))
+import Language.Haskell.Exts.Syntax (Decl, InstDecl)
 
 -----
 

diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs
@@ -42,7 +42,7 @@ import FFICXX.Generate.Type.Module
 import FFICXX.Generate.Util (toLowers)
 import FFICXX.Generate.Util.HaskellSrcExts (mkForImpCcall, mkImport)
 import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))
-import Language.Haskell.Exts.Syntax (Decl (..), ImportDecl (..))
+import Language.Haskell.Exts.Syntax (Decl, ImportDecl)
 import System.FilePath ((<.>))
 
 genHsFFI :: ClassImportHeader -> [Decl ()]

diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs
@@ -105,10 +105,9 @@ import FFICXX.Generate.Util.HaskellSrcExts
   )
 import Language.Haskell.Exts.Build (app, letE, name, pApp)
 import Language.Haskell.Exts.Syntax
-  ( Context (CxTuple),
-    Decl (..),
-    ExportSpec (..),
-    ImportDecl (..),
+  ( Decl,
+    ExportSpec,
+    ImportDecl,
   )
 import System.FilePath ((<.>))
 
@@ -120,7 +119,7 @@ genHsFrontDecl isHsBoot c = do
   -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap
   let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body
       -- for hs-boot, we only have instance head.
-      cdecl' = mkClass (CxTuple () []) (typeclassName c) [mkTBind "a"] []
+      cdecl' = mkClass (cxTuple []) (typeclassName c) [mkTBind "a"] []
       sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f)
       body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c
   if isHsBoot

diff --git a/fficxx/src/FFICXX/Generate/Code/HsProxy.hs b/fficxx/src/FFICXX/Generate/Code/HsProxy.hs
@@ -3,45 +3,53 @@
 module FFICXX.Generate.Code.HsProxy where
 
 import qualified Data.List as L (foldr1)
---
-
-import FFICXX.Generate.Util.HaskellSrcExts
-  ( con,
+import FFICXX.Generate.Util.GHCExactPrint
+  ( app,
+    con,
+    doE,
     inapp,
+    listE,
+    mkBodyStmt,
     mkFun,
     mkVar,
     op,
-    qualifier,
+    par,
+    strE,
     tyapp,
     tycon,
     tylist,
   )
 import qualified FFICXX.Runtime.CodeGen.Cxx as R
-import Language.Haskell.Exts.Build (app, doE, listE, qualStmt, strE)
-import Language.Haskell.Exts.Syntax (Decl (..))
+import GHC.Hs.Extension
+  ( GhcPs,
+  )
+import Language.Haskell.Syntax.Decls (HsDecl)
 
-genProxyInstance :: [Decl ()]
-genProxyInstance =
-  mkFun fname sig [] rhs Nothing
+genProxyInstance :: [HsDecl GhcPs]
+genProxyInstance = mkFun fname sig [] rhs Nothing
   where
     fname = "genImplProxy"
-    v = mkVar
     sig = tycon "Q" `tyapp` tylist (tycon "Dec")
-    rhs = doE [foreignSrcStmt, qualStmt retstmt]
+    rhs = doE [foreignSrcStmt, retstmt]
+
+    v = mkVar
+    retstmt = mkBodyStmt (v "pure" `app` listE [])
+
     foreignSrcStmt =
-      qualifier $
+      mkBodyStmt $
         (v "addModFinalizer")
-          `app` ( v "addForeignSource"
-                    `app` con "LangCxx"
-                    `app` ( L.foldr1
-                              (\x y -> inapp x (op "++") y)
-                              [includeStatic]
-                          )
-                )
+          `app` par
+            ( v "addForeignSource"
+                `app` con "LangCxx"
+                `app` par
+                  ( L.foldr1
+                      (\x y -> inapp x (op "++") y)
+                      [includeStatic]
+                  )
+            )
       where
         includeStatic =
           strE $
             concatMap
               (<> "\n")
               [R.renderCMacro (R.Include "MacroPatternMatch.h")]
-    retstmt = v "pure" `app` listE []