Submodule dependency computation and cyclic dep hs-boot resolution sy…

…stem (#204)

Submodules (RawType, FFI, Interface, Cast, Implementation for class, Template, TH for template class) had been explicitly defined in the last commit and their dependencies are more precisely computed for producing dependency graph.
Now the codegen system uses the dep graph information for import modules and detect cyclic dependencies by strongly connected components from the graph. The cycles are made broken by restricted dependency analysis and proper hs-boot generation (relatively correct compared with previous naive implementation)
Now stdcxx, OGDF, HROOT and hgdal are buildable again.

* unify formatOrdinary/Template to subModuleName and place it in Generate.Name.
* refactor out constructDepGraph.
* findDepCycles. pass depCycles to Interface builder.
* use full module name in subModuleName (and dependency info)
* use SOURCE pragma as computed from dependency graph.
* move Submodule-related types to Type.Module
* start unified calculateDependency, no mkModuleDepRaw.
* unify mkModuleDepExternal into calculateDependency
* remove mkModuleDepInplace. not yet correct
* unify imported modules in ClassModule. Bug fix in calculateDependency.
* remove mkModuleDepFFI
* include Cast.hs dep in calculateDependency
* Implementation dependency calculation. now calculateDependency definition is completed.
* self RawType is included in calculateDependency
* unify dependency generation in Graph module.
* bug fix: only virtualFuncs for Interface.hs dependency!
* remove warnings
* find dependency inside cycles, and gather hs-boot candidates.
* corrected hs-boot file generation by not importing cyclic modules
and using empty class context and body.

fficxx-runtime/src/FFICXX/Runtime/Cast.hs

@@ -12,6 +12,7 @@ module FFICXX.Runtime.Cast where
 
 import Data.ByteString.Char8 (ByteString, packCString, useAsCString)
 import Data.Int (Int16, Int32, Int64, Int8)
+import Data.Kind (Type)
 import Data.Word (Word16, Word32, Word64, Word8)
 import Foreign.C
   ( CBool,
@@ -55,14 +56,14 @@ class Castable a b where
   uncast :: b -> (a -> IO r) -> IO r
 
 class FPtr a where
-  type Raw a :: *
+  type Raw a :: Type
   get_fptr :: a -> Ptr (Raw a)
   cast_fptr_to_obj :: Ptr (Raw a) -> a
 
 class FunPtrWrappable a where
-  type FunPtrHsType a :: *
-  type FunPtrType a :: *
-  data FunPtrWrapped a :: *
+  type FunPtrHsType a :: Type
+  type FunPtrType a :: Type
+  data FunPtrWrapped a :: Type
   fptrWrap :: FunPtrWrapped a -> IO (FunPtr (FunPtrType a))
   wrap :: FunPtrHsType a -> FunPtrWrapped a
 

fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs

@@ -5,6 +5,7 @@ module FFICXX.Runtime.CodeGen.Cxx where
 
 import Data.Functor.Identity (Identity)
 import Data.Hashable (Hashable)
+import Data.Kind (Type)
 import Data.List (intercalate)
 import Data.String (IsString (..))
 
@@ -23,9 +24,9 @@ instance IsString Namespace where
 data PragmaParam = Once
 
 -- | parts for interpolation
-newtype NamePart (f :: * -> *) = NamePart String
+newtype NamePart (f :: Type -> Type) = NamePart String
 
-newtype CName (f :: * -> *) = CName [NamePart f]
+newtype CName (f :: Type -> Type) = CName [NamePart f]
 
 sname :: String -> CName Identity
 sname s = CName [NamePart s]
@@ -34,7 +35,7 @@ renderCName :: CName Identity -> String
 renderCName (CName ps) = intercalate "##" $ map (\(NamePart p) -> p) ps
 
 -- | Types
-data CType (f :: * -> *)
+data CType (f :: Type -> Type)
   = CTVoid
   | CTSimple (CName f)
   | CTStar (CType f)
@@ -56,7 +57,7 @@ renderCOp :: COp -> String
 renderCOp CArrow = "->"
 renderCOp CAssign = "="
 
-data CExp (f :: * -> *)
+data CExp (f :: Type -> Type)
   = -- | variable
     CVar (CName f)
   | -- | C function app:  f(a1,a2,..)
@@ -84,11 +85,11 @@ data CExp (f :: * -> *)
   | -- | empty C expression. (for convenience)
     CNull
 
-data CFunDecl (f :: * -> *)
+data CFunDecl (f :: Type -> Type)
   = -- | type func( type1 arg1, type2 arg2, ... )
     CFunDecl (CType f) (CName f) [(CType f, CName f)]
 
-data CVarDecl (f :: * -> *)
+data CVarDecl (f :: Type -> Type)
   = CVarDecl
       (CType f)
       -- ^ type
@@ -97,7 +98,7 @@ data CVarDecl (f :: * -> *)
 
 data CQual = Inline
 
-data CStatement (f :: * -> *)
+data CStatement (f :: Type -> Type)
   = -- | using namespace <namespace>;
     UsingNamespace Namespace
   | -- | typedef origtype newname;
@@ -125,7 +126,7 @@ data CStatement (f :: * -> *)
   | -- | temporary verbatim
     CVerbatim String
 
-data CMacro (f :: * -> *)
+data CMacro (f :: Type -> Type)
   = -- | regular C++ statement
     CRegular (CStatement f)
   | -- | #include "<header>"
@@ -141,7 +142,7 @@ data CMacro (f :: * -> *)
   | -- | temporary verbatim
     Verbatim String
 
-data CBlock (f :: * -> *) = ExternC [CMacro f] -- extern "C" with #ifdef __cplusplus guard.
+data CBlock (f :: Type -> Type) = ExternC [CMacro f] -- extern "C" with #ifdef __cplusplus guard.
 
 renderPragmaParam :: PragmaParam -> String
 renderPragmaParam Once = "once"

fficxx/fficxx.cabal

@@ -20,6 +20,7 @@ Library
   Build-Depends: base == 4.*
                , aeson
                , aeson-pretty
+               , array
                , bytestring
                , Cabal
                , containers
@@ -54,6 +55,7 @@ Library
                FFICXX.Generate.Code.Primitive
                FFICXX.Generate.ContentMaker
                FFICXX.Generate.Dependency
+               FFICXX.Generate.Dependency.Graph
                FFICXX.Generate.Name
                FFICXX.Generate.QQ.Verbatim
                FFICXX.Generate.Util

fficxx/src/FFICXX/Generate/Builder.hs

@@ -8,6 +8,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
 import Data.Char (toUpper)
 import Data.Digest.Pure.MD5 (md5)
 import Data.Foldable (for_)
+import qualified Data.Text as T
 import FFICXX.Generate.Code.Cabal (buildCabalFile, buildJSONFile)
 import FFICXX.Generate.Config
   ( FFICXXConfig (..),
@@ -16,10 +17,13 @@ import FFICXX.Generate.Config
 import qualified FFICXX.Generate.ContentMaker as C
 import FFICXX.Generate.Dependency
   ( findModuleUnitImports,
-    getClassModuleBase,
-    mkHsBootCandidateList,
     mkPackageConfig,
   )
+import FFICXX.Generate.Dependency.Graph
+  ( constructDepGraph,
+    findDepCycles,
+    gatherHsBootSubmodules,
+  )
 import FFICXX.Generate.Type.Cabal
   ( AddCInc (..),
     AddCSrc (..),
@@ -31,6 +35,7 @@ import FFICXX.Generate.Type.Module
   ( ClassImportHeader (..),
     ClassModule (..),
     PackageConfig (..),
+    TemplateClassImportHeader (..),
     TemplateClassModule (..),
     TopLevelImportHeader (..),
   )
@@ -77,9 +82,20 @@ simpleBuilder cfg sbc = do
           (classes, toplevelfunctions, templates, extramods)
           (cabal_additional_c_incs cabal)
           (cabal_additional_c_srcs cabal)
-      hsbootlst = mkHsBootCandidateList mods
       cabalFileName = unCabalName pkgname <.> "cabal"
       jsonFileName = unCabalName pkgname <.> "json"
+      allClasses = fmap (Left . tcihTClass) templates ++ fmap Right classes
+      depCycles =
+        findDepCycles $
+          constructDepGraph allClasses toplevelfunctions
+      -- for now, put this function here
+      -- This function is a little ad hoc, only for Interface.hs.
+      -- But as of now, we support hs-boot for ordinary class only.
+      mkHsBootCandidateList :: [ClassModule] -> [ClassModule]
+      mkHsBootCandidateList ms =
+        let hsbootSubmods = gatherHsBootSubmodules depCycles
+         in filter (\c -> cmModule c <.> "Interface" `elem` hsbootSubmods) ms
+      hsbootlst = mkHsBootCandidateList mods
   --
   createDirectoryIfMissing True workingDir
   createDirectoryIfMissing True installDir
@@ -131,7 +147,7 @@ simpleBuilder cfg sbc = do
   for_ mods $ \m ->
     gen
       (cmModule m <.> "Interface" <.> "hs")
-      (prettyPrint (C.buildInterfaceHs mempty m))
+      (prettyPrint (C.buildInterfaceHs mempty depCycles m))
   --
   putStrLn "Generating Cast.hs"
   for_ mods $ \m ->
@@ -164,10 +180,14 @@ simpleBuilder cfg sbc = do
   --
   -- TODO: Template.hs-boot need to be generated as well
   putStrLn "Generating hs-boot file"
+  -- This is a hack since haskell-src-exts always codegen () => instead of empty
+  -- string for an empty context, which have different meanings in hs-boot file.
+  -- Therefore, we get rid of them.
+  let hsBootHackClearEmptyContexts = T.unpack . T.replace "() =>" "" . T.pack
   for_ hsbootlst $ \m -> do
     gen
       (cmModule m <.> "Interface" <.> "hs-boot")
-      (prettyPrint (C.buildInterfaceHsBoot m))
+      (hsBootHackClearEmptyContexts $ prettyPrint (C.buildInterfaceHsBoot depCycles m))
   --
   putStrLn "Generating Module summary file"
   for_ mods $ \m ->

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

@@ -13,14 +13,13 @@ import FFICXX.Generate.Code.Primitive
   )
 import FFICXX.Generate.Dependency
   ( class_allparents,
-    getClassModuleBase,
-    getTClassModuleBase,
   )
 import FFICXX.Generate.Name
   ( aliasedFuncName,
     ffiClassName,
     hscAccessorName,
     hscFuncName,
+    subModuleName,
   )
 import FFICXX.Generate.Type.Class
   ( Accessor (Getter, Setter),
@@ -89,12 +88,8 @@ hsFFIAccessor c v a =
    in mkForImpCcall cname (hscAccessorName c v a) typ
 
 -- import for FFI
-
 genImportInFFI :: ClassModule -> [ImportDecl ()]
-genImportInFFI = map mkMod . cmImportedModulesFFI
-  where
-    mkMod (Left t) = mkImport (getTClassModuleBase t <.> "Template")
-    mkMod (Right c) = mkImport (getClassModuleBase c <.> "RawType")
+genImportInFFI = fmap (mkImport . subModuleName) . cmImportedSubmodulesForFFI
 
 ----------------------------
 -- for top level function --