From 6ce14cae7ea4e561849ee307e4acf39dd38d92cb Mon Sep 17 00:00:00 2001 From: Ian-Woo Kim Date: Thu, 8 Dec 2022 10:55:17 -0800 Subject: [PATCH] Submodule dependency computation and cyclic dep hs-boot resolution system (#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 | 9 +- .../src/FFICXX/Runtime/CodeGen/Cxx.hs | 19 +- fficxx/fficxx.cabal | 2 + fficxx/src/FFICXX/Generate/Builder.hs | 30 ++- fficxx/src/FFICXX/Generate/Code/HsFFI.hs | 9 +- fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs | 113 ++++----- fficxx/src/FFICXX/Generate/Code/HsTemplate.hs | 44 +--- fficxx/src/FFICXX/Generate/ContentMaker.hs | 28 +-- fficxx/src/FFICXX/Generate/Dependency.hs | 237 +++++++++--------- .../src/FFICXX/Generate/Dependency/Graph.hs | 117 +++++++++ fficxx/src/FFICXX/Generate/Name.hs | 49 +++- fficxx/src/FFICXX/Generate/Type/Module.hs | 57 ++++- fficxx/src/FFICXX/Generate/Util/DepGraph.hs | 182 +------------- 13 files changed, 442 insertions(+), 454 deletions(-) create mode 100644 fficxx/src/FFICXX/Generate/Dependency/Graph.hs diff --git a/fficxx-runtime/src/FFICXX/Runtime/Cast.hs b/fficxx-runtime/src/FFICXX/Runtime/Cast.hs index cb5247bd..ef0ba2e1 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/Cast.hs +++ b/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 diff --git a/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs b/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs index be00c09d..cfc3d57a 100644 --- a/fficxx-runtime/src/FFICXX/Runtime/CodeGen/Cxx.hs +++ b/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 ; 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 "
" @@ -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" diff --git a/fficxx/fficxx.cabal b/fficxx/fficxx.cabal index 9dfb772d..a6d7d524 100644 --- a/fficxx/fficxx.cabal +++ b/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 diff --git a/fficxx/src/FFICXX/Generate/Builder.hs b/fficxx/src/FFICXX/Generate/Builder.hs index 4eca99b3..3f01c3d8 100644 --- a/fficxx/src/FFICXX/Generate/Builder.hs +++ b/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 -> diff --git a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs b/fficxx/src/FFICXX/Generate/Code/HsFFI.hs index 949aa33d..035daa23 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFFI.hs +++ b/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 -- diff --git a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs index a50f3fb9..447d28b0 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -7,7 +7,7 @@ module FFICXX.Generate.Code.HsFrontEnd where import Control.Monad.Reader (Reader) import Data.Either (lefts, rights) -import Data.List (nub) +import qualified Data.List as L import FFICXX.Generate.Code.Primitive ( CFunSig (..), HsFunSig (..), @@ -20,21 +20,25 @@ import FFICXX.Generate.Code.Primitive ) import FFICXX.Generate.Dependency ( argumentDependency, - class_allparents, extractClassDepForTLOrdinary, extractClassDepForTLTemplate, - getClassModuleBase, - getTClassModuleBase, returnDependency, ) +import FFICXX.Generate.Dependency.Graph + ( getCyclicDepSubmodules, + locateInDepCycles, + ) import FFICXX.Generate.Name ( accessorName, aliasedFuncName, + getClassModuleBase, + getTClassModuleBase, hsClassName, hsFrontNameForTopLevel, hsFuncName, hscAccessorName, hscFuncName, + subModuleName, typeclassName, ) import FFICXX.Generate.Type.Annotate (AnnotateMap) @@ -54,8 +58,8 @@ import FFICXX.Generate.Type.Class virtualFuncs, ) import FFICXX.Generate.Type.Module - ( ClassImportHeader (..), - ClassModule (..), + ( ClassModule (..), + DepCycles, TemplateClassModule (..), ) import FFICXX.Generate.Util (toLowers) @@ -80,7 +84,7 @@ import FFICXX.Generate.Util.HaskellSrcExts mkFun, mkFunSig, mkImport, - -- mkImportSrc, + mkImportSrc, mkInstance, mkNewtype, mkPVar, @@ -100,19 +104,28 @@ import FFICXX.Generate.Util.HaskellSrcExts unqual, ) import Language.Haskell.Exts.Build (app, letE, name, pApp) -import Language.Haskell.Exts.Syntax (Decl (..), ExportSpec (..), ImportDecl (..)) +import Language.Haskell.Exts.Syntax + ( Context (CxTuple), + Decl (..), + ExportSpec (..), + ImportDecl (..), + ) import System.FilePath ((<.>)) -genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ()) -genHsFrontDecl c = do +genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ()) +genHsFrontDecl isHsBoot c = do -- TODO: revive annotation -- for the time being, let's ignore annotation. -- amap <- ask -- 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"] [] sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c - return cdecl + if isHsBoot + then return cdecl' + else return cdecl ------------------- @@ -323,59 +336,37 @@ genExtraImport cm = map mkImport (cmExtraImport cm) genImportInModule :: Class -> [ImportDecl ()] genImportInModule x = map (\y -> mkImport (getClassModuleBase x <.> y)) ["RawType", "Interface", "Implementation"] --- TODO: this dependency should be refactored out and analyzed separately, particularly for cyclic deps. -genImportInInterface :: ClassModule -> [ImportDecl ()] -genImportInInterface m = - let modsRaw = cmImportedModulesRaw m - modsExt = cmImportedModulesExternal m - modsInplace = cmImportedModulesInplace m - in [mkImport (cmModule m <.> "RawType")] - <> flip - map - modsRaw - ( \case - Left t -> mkImport (getTClassModuleBase t <.> "Template") - Right c -> mkImport (getClassModuleBase c <.> "RawType") - ) - <> flip - map - modsExt - ( \case - Left t -> mkImport (getTClassModuleBase t <.> "Template") - Right c -> mkImport (getClassModuleBase c <.> "Interface") - ) - <> flip - map - modsInplace - ( \case - Left t -> - -- TODO: *.Template in the same package needs to have hs-boot. - -- Currently, we do not have it yet. - mkImport (getTClassModuleBase t <.> "Template") - Right c -> mkImport (getClassModuleBase c <.> "Interface") - -- mkImportSrc (getClassModuleBase c <.> "Interface") - ) +mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl () +mkImportWithDepCycles depCycles self imported = + let mloc = locateInDepCycles (self, imported) depCycles + in case mloc of + Just (idxSelf, idxImported) + | idxImported > idxSelf -> + mkImportSrc imported + _ -> mkImport imported + +genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()] +genImportInInterface isHsBoot depCycles m = + let modSelf = cmModule m <.> "Interface" + imported = cmImportedSubmodulesForInterface m + (rdepsU, rdepsD) = getCyclicDepSubmodules modSelf depCycles + in if isHsBoot + then -- for hs-boot file, we ignore all module imports in the cycle. + -- TODO: This is likely to be broken in more general cases. + -- Keep improving this as hs-boot allows. + + let imported' = fmap subModuleName imported L.\\ (rdepsU <> rdepsD) + in fmap mkImport imported' + else fmap (mkImportWithDepCycles depCycles modSelf . subModuleName) imported -- | genImportInCast :: ClassModule -> [ImportDecl ()] genImportInCast m = - [ mkImport (cmModule m <.> "RawType"), - mkImport (cmModule m <.> "Interface") - ] + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m --- | genImportInImplementation :: ClassModule -> [ImportDecl ()] genImportInImplementation m = - let modsFFI = cmImportedModulesFFI m - modsParents = nub $ map Right $ class_allparents $ cihClass $ cmCIH m - modsNonParents = filter (not . (flip elem modsParents)) modsFFI - in [ mkImport (cmModule m <.> "RawType"), - mkImport (cmModule m <.> "FFI"), - mkImport (cmModule m <.> "Interface"), - mkImport (cmModule m <.> "Cast") - ] - <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType", "Cast", "Interface"]) modsNonParents - <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType", "Cast", "Interface"]) modsParents + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m -- | generate import list for a given top-level ordinary function -- currently this may generate duplicate import list. @@ -385,8 +376,8 @@ genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()] genImportForTLOrdinary f = let dep4func = extractClassDepForTLOrdinary f ecs = returnDependency dep4func ++ argumentDependency dep4func - cmods = nub $ map getClassModuleBase $ rights ecs - tmods = nub $ map getTClassModuleBase $ lefts ecs + cmods = L.nub $ map getClassModuleBase $ rights ecs + tmods = L.nub $ map getTClassModuleBase $ lefts ecs in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods @@ -398,8 +389,8 @@ genImportForTLTemplate :: TLTemplate -> [ImportDecl ()] genImportForTLTemplate f = let dep4func = extractClassDepForTLTemplate f ecs = returnDependency dep4func ++ argumentDependency dep4func - cmods = nub $ map getClassModuleBase $ rights ecs - tmods = nub $ map getTClassModuleBase $ lefts ecs + cmods = L.nub $ map getClassModuleBase $ rights ecs + tmods = L.nub $ map getTClassModuleBase $ lefts ecs in concatMap (\x -> map (\y -> mkImport (x <.> y)) ["RawType", "Cast", "Interface"]) cmods <> concatMap (\x -> map (\y -> mkImport (x <.> y)) ["Template"]) tmods diff --git a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs index ad8086c3..7edb625d 100644 --- a/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/fficxx/src/FFICXX/Generate/Code/HsTemplate.hs @@ -19,12 +19,7 @@ import FFICXX.Generate.Code.Primitive functionSignatureTT, tmplAccessorToTFun, ) -import FFICXX.Generate.Dependency - ( getClassModuleBase, - getTClassModuleBase, - mkModuleDepInplace, - mkModuleDepRaw, - ) +import FFICXX.Generate.Dependency (calculateDependency) import FFICXX.Generate.Name ( ffiTmplFuncName, hsTemplateClassName, @@ -32,6 +27,7 @@ import FFICXX.Generate.Name hsTemplateMemberFunctionNameTH, hsTmplFuncName, hsTmplFuncNameTH, + subModuleName, tmplAccessorName, typeclassNameT, ) @@ -49,6 +45,7 @@ import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Module ( ClassImportHeader (..), TemplateClassImportHeader (..), + TemplateClassSubmoduleType (..), TopLevelImportHeader (..), ) import FFICXX.Generate.Util (firstUpper) @@ -110,7 +107,6 @@ import Language.Haskell.Exts.Build wildcard, ) import Language.Haskell.Exts.Syntax (Boxed (Boxed), Decl (..), ImportDecl (..), Type (TyTuple)) -import System.FilePath ((<.>)) ------------------------------ -- Template member function -- @@ -236,22 +232,7 @@ genTMFInstance cih f = genImportInTemplate :: TemplateClass -> [ImportDecl ()] genImportInTemplate t0 = - let depsRaw = mkModuleDepRaw (Left t0) - depsInplace = mkModuleDepInplace (Left t0) - in flip - map - depsRaw - ( \case - Left t -> mkImport (getTClassModuleBase t <.> "Template") - Right c -> mkImport (getClassModuleBase c <.> "RawType") - ) - <> flip - map - depsInplace - ( \case - Left t -> mkImport (getTClassModuleBase t <.> "Template") - Right c -> mkImport (getClassModuleBase c <.> "Interface") - ) + fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTemplate, t0) -- | genTmplInterface :: TemplateClass -> [Decl ()] @@ -288,22 +269,7 @@ genTmplInterface t = -- | genImportInTH :: TemplateClass -> [ImportDecl ()] genImportInTH t0 = - let depsRaw = mkModuleDepRaw (Left t0) - depsInplace = mkModuleDepInplace (Left t0) - in flip - concatMap - depsRaw - ( \case - Left t -> [mkImport (getTClassModuleBase t <.> "Template")] - Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType", "Cast", "Interface"] - ) - <> flip - concatMap - depsInplace - ( \case - Left t -> [mkImport (getTClassModuleBase t <.> "Template")] - Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType", "Cast", "Interface"] - ) + fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0) -- | genTmplImplementation :: TemplateClass -> [Decl ()] diff --git a/fficxx/src/FFICXX/Generate/ContentMaker.hs b/fficxx/src/FFICXX/Generate/ContentMaker.hs index 58c8b520..79417d8e 100644 --- a/fficxx/src/FFICXX/Generate/ContentMaker.hs +++ b/fficxx/src/FFICXX/Generate/ContentMaker.hs @@ -71,12 +71,8 @@ import FFICXX.Generate.Code.HsTemplate genTmplInstance, genTmplInterface, ) -import FFICXX.Generate.Code.Primitive - ( classConstraints, - ) import FFICXX.Generate.Dependency ( class_allparents, - getClassModuleBase, mkDaughterMap, mkDaughterSelfMap, ) @@ -84,7 +80,6 @@ import FFICXX.Generate.Name ( ffiClassName, hsClassName, hsFrontNameForTopLevel, - typeclassName, ) import FFICXX.Generate.Type.Annotate (AnnotateMap) import FFICXX.Generate.Type.Class @@ -100,6 +95,7 @@ import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Module ( ClassImportHeader (..), ClassModule (..), + DepCycles, TemplateClassImportHeader (..), TemplateClassModule (..), TopLevelImportHeader (..), @@ -114,11 +110,9 @@ import FFICXX.Generate.Util.HaskellSrcExts ( emodule, evar, lang, - mkClass, mkImport, mkModule, mkModuleE, - mkTBind, unqual, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) @@ -390,8 +384,12 @@ buildRawTypeHs m = in if isAbstractClass c then [] else hsClassRawType c -- | -buildInterfaceHs :: AnnotateMap -> ClassModule -> Module () -buildInterfaceHs amap m = +buildInterfaceHs :: + AnnotateMap -> + DepCycles -> + ClassModule -> + Module () +buildInterfaceHs amap depCycles m = mkModule (cmModule m <.> "Interface") [ lang @@ -417,16 +415,16 @@ buildInterfaceHs amap m = mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] - <> genImportInInterface m + <> genImportInInterface False depCycles m <> genExtraImport m ifaceBody = - runReader (mapM genHsFrontDecl classes) amap + runReader (mapM (genHsFrontDecl False) classes) amap <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes -- | -buildInterfaceHsBoot :: ClassModule -> Module () -buildInterfaceHsBoot m = +buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module () +buildInterfaceHsBoot depCycles m = mkModule (cmModule m <.> "Interface") [ lang @@ -452,10 +450,10 @@ buildInterfaceHsBoot m = mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] - <> genImportInInterface m + <> genImportInInterface True depCycles m <> genExtraImport m hsbootBody = - runReader (mapM genHsFrontDecl [c]) M.empty + runReader (mapM (genHsFrontDecl True) [c]) M.empty -- | buildCastHs :: ClassModule -> Module () diff --git a/fficxx/src/FFICXX/Generate/Dependency.hs b/fficxx/src/FFICXX/Generate/Dependency.hs index 7ee3190e..d6ea68a7 100644 --- a/fficxx/src/FFICXX/Generate/Dependency.hs +++ b/fficxx/src/FFICXX/Generate/Dependency.hs @@ -20,25 +20,24 @@ module FFICXX.Generate.Dependency where -- dependency class list and finally get the import list for the module corresponding to -- a given class. +import Data.Bifunctor (bimap) import Data.Either (rights) import Data.Function (on) import qualified Data.HashMap.Strict as HM -import Data.List (find, foldl', nub, nubBy) +import qualified Data.List as L (find, foldl', nub, nubBy) import qualified Data.Map as M import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import FFICXX.Generate.Name - ( ClassModuleType (..), - TemplateClassModuleType (..), - ffiClassName, + ( ffiClassName, + getClassModuleBase, + getTClassModuleBase, hsClassName, - hsTemplateClassName, ) import FFICXX.Generate.Type.Cabal ( AddCInc, AddCSrc, CabalName (..), cabal_cheaderprefix, - cabal_moduleprefix, cabal_pkgname, unCabalName, ) @@ -60,6 +59,7 @@ import FFICXX.Generate.Type.Class Variable (unVariable), argsFromOpExp, filterTLOrdinary, + virtualFuncs, ) import FFICXX.Generate.Type.Config ( ModuleUnit (..), @@ -70,10 +70,13 @@ import FFICXX.Generate.Type.Config import FFICXX.Generate.Type.Module ( ClassImportHeader (..), ClassModule (..), + ClassSubmoduleType (..), PackageConfig (..), TemplateClassImportHeader (..), TemplateClassModule (..), + TemplateClassSubmoduleType (..), TopLevelImportHeader (..), + UClassSubmodule, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import System.FilePath ((<.>)) @@ -117,13 +120,7 @@ class_allparents c = let ps = class_parents c in if null ps then [] - else nub (ps <> (concatMap class_allparents ps)) - -getClassModuleBase :: Class -> String -getClassModuleBase = (<.>) <$> (cabal_moduleprefix . class_cabal) <*> (fst . hsClassName) - -getTClassModuleBase :: TemplateClass -> String -getTClassModuleBase = (<.>) <$> (cabal_moduleprefix . tclass_cabal) <*> (fst . hsTemplateClassName) + else L.nub (ps <> (concatMap class_allparents ps)) -- | Daughter map not including itself mkDaughterMap :: [Class] -> DaughterMap @@ -139,7 +136,7 @@ mkDaughterMap = foldl mkDaughterMapWorker M.empty -- | Daughter Map including itself as a daughter mkDaughterSelfMap :: [Class] -> DaughterMap -mkDaughterSelfMap = foldl' worker M.empty +mkDaughterSelfMap = L.foldl' worker M.empty where worker m c = let ps = map getClassModuleBase (c : class_allparents c) @@ -204,20 +201,104 @@ extractClassDepForTLTemplate f = ret = topleveltfunc_ret f args = topleveltfunc_args f --- TODO: Confirm the answer below is correct. --- NOTE: Q: Why returnDependency only? +mkDepFFI :: Class -> [UClassSubmodule] +mkDepFFI cls = + let ps = map Right (class_allparents cls) + alldeps' = concatMap go ps <> go (Right cls) + depSelf = Right (CSTRawType, cls) + in depSelf : (fmap (bimap (TCSTTemplate,) (CSTRawType,)) $ L.nub $ filter (/= Right cls) alldeps') + where + go (Right c) = + let fs = class_funcs c + vs = class_vars c + tmfs = class_tmpl_funcs c + in concatMap (returnDependency . extractClassDep) fs + <> concatMap (argumentDependency . extractClassDep) fs + <> concatMap (classFromArg . unVariable) vs + <> concatMap (returnDependency . extractClassDep4TmplMemberFun) tmfs + <> concatMap (argumentDependency . extractClassDep4TmplMemberFun) tmfs + go (Left t) = + let fs = tclass_funcs t + in concatMap (returnDependency . extractClassDepForTmplFun) fs + <> concatMap (argumentDependency . extractClassDepForTmplFun) fs + +-- For raws: +-- NOTE: Q: Why returnDependency for RawTypes? -- A: Difference between argument and return: -- for a member function f, -- we have (f :: (IA a, IB b) => a -> b -> IO C -- return class is concrete and argument class is constraint. -mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepRaw x@(Right c) = - nub $ - filter (/= x) $ - concatMap (returnDependency . extractClassDep) (class_funcs c) - ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c) -mkModuleDepRaw x@(Left t) = - (nub . filter (/= x) . concatMap (returnDependency . extractClassDepForTmplFun) . tclass_funcs) t +calculateDependency :: UClassSubmodule -> [UClassSubmodule] +calculateDependency (Left (typ, tcl)) = raws <> inplaces + where + raws' = + L.nub $ + filter (/= Left tcl) $ + concatMap (returnDependency . extractClassDepForTmplFun) $ + tclass_funcs tcl + raws = + case typ of + TCSTTemplate -> + fmap (bimap (TCSTTemplate,) (CSTRawType,)) raws' + TCSTTH -> + concatMap + ( \case + Left t -> [Left (TCSTTemplate, t)] + Right c -> fmap (Right . (,c)) [CSTRawType, CSTCast, CSTInterface] + ) + raws' + inplaces = + let fs = tclass_funcs tcl + in fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ + L.nub $ + filter (`isInSamePackageButNotInheritedBy` Left tcl) $ + concatMap (argumentDependency . extractClassDepForTmplFun) fs +calculateDependency (Right (CSTRawType, _)) = [] +calculateDependency (Right (CSTFFI, cls)) = mkDepFFI cls +calculateDependency (Right (CSTInterface, cls)) = + let retDepClasses = + concatMap (returnDependency . extractClassDep) (virtualFuncs $ class_funcs cls) + ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs cls) + argDepClasses = + concatMap (argumentDependency . extractClassDep) (virtualFuncs $ class_funcs cls) + ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs cls) + rawSelf = Right (CSTRawType, cls) + raws = + fmap (bimap (TCSTTemplate,) (CSTRawType,)) $ L.nub $ filter (/= Right cls) retDepClasses + exts = + let extclasses = + filter (`isNotInSamePackageWith` Right cls) argDepClasses + parents = map Right (class_parents cls) + in fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ L.nub (parents <> extclasses) + inplaces = + fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ + L.nub $ + filter (`isInSamePackageButNotInheritedBy` Right cls) $ argDepClasses + in rawSelf : (raws ++ exts ++ inplaces) +calculateDependency (Right (CSTCast, cls)) = [Right (CSTRawType, cls), Right (CSTInterface, cls)] +calculateDependency (Right (CSTImplementation, cls)) = + let depsSelf = + [ Right (CSTRawType, cls), + Right (CSTFFI, cls), + Right (CSTInterface, cls), + Right (CSTCast, cls) + ] + dsFFI = fmap (bimap snd snd) $ mkDepFFI cls + dsParents = L.nub $ map Right $ class_allparents cls + dsNonParents = filter (not . (flip elem dsParents)) dsFFI + + deps = + concatMap + ( \case + Left t -> [Left (TCSTTemplate, t)] + Right c -> + [ Right (CSTRawType, c), + Right (CSTCast, c), + Right (CSTInterface, c) + ] + ) + (dsNonParents <> dsParents) + in depsSelf <> deps -- | isNotInSamePackageWith :: @@ -236,45 +317,13 @@ isInSamePackageButNotInheritedBy :: isInSamePackageButNotInheritedBy x y = x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y) --- TODO: Confirm the following answer --- NOTE: Q: why returnDependency is not considered? --- A: See explanation in mkModuleDepRaw -mkModuleDepExternal :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepExternal y@(Right c) = - let extclasses = - filter (`isNotInSamePackageWith` y) $ - concatMap (argumentDependency . extractClassDep) (class_funcs c) - ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c) - parents = map Right (class_parents c) - in nub (parents <> extclasses) -mkModuleDepExternal y@(Left t) = - let fs = tclass_funcs t - extclasses = - filter (`isNotInSamePackageWith` y) $ - concatMap (argumentDependency . extractClassDepForTmplFun) fs - in nub extclasses - --- NOTE: Q: why returnDependency is not considered? --- A: See explanation in mkModuleDepRaw -mkModuleDepInplace :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepInplace y@(Right c) = - nub $ - filter (`isInSamePackageButNotInheritedBy` y) $ - concatMap (argumentDependency . extractClassDep) (class_funcs c) - ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c) -mkModuleDepInplace y@(Left t) = - let fs = tclass_funcs t - in nub $ - filter (`isInSamePackageButNotInheritedBy` y) $ - concatMap (argumentDependency . extractClassDepForTmplFun) fs - -- | mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class] mkModuleDepCpp y@(Right c) = let fs = class_funcs c vs = class_vars c tmfs = class_tmpl_funcs c - in nub . filter (/= y) $ + in L.nub . filter (/= y) $ concatMap (returnDependency . extractClassDep) fs <> concatMap (argumentDependency . extractClassDep) fs <> concatMap (classFromArg . unVariable) vs @@ -283,53 +332,24 @@ mkModuleDepCpp y@(Right c) = <> getparents y mkModuleDepCpp y@(Left t) = let fs = tclass_funcs t - in nub . filter (/= y) $ + in L.nub . filter (/= y) $ concatMap (returnDependency . extractClassDepForTmplFun) fs <> concatMap (argumentDependency . extractClassDepForTmplFun) fs <> getparents y --- | -mkModuleDepFFI1 :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepFFI1 (Right c) = - let fs = class_funcs c - vs = class_vars c - tmfs = class_tmpl_funcs c - in concatMap (returnDependency . extractClassDep) fs - <> concatMap (argumentDependency . extractClassDep) fs - <> concatMap (classFromArg . unVariable) vs - <> concatMap (returnDependency . extractClassDep4TmplMemberFun) tmfs - <> concatMap (argumentDependency . extractClassDep4TmplMemberFun) tmfs -mkModuleDepFFI1 (Left t) = - let fs = tclass_funcs t - in concatMap (returnDependency . extractClassDepForTmplFun) fs - <> concatMap (argumentDependency . extractClassDepForTmplFun) fs - --- | -mkModuleDepFFI :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepFFI y@(Right c) = - let ps = map Right (class_allparents c) - alldeps' = (concatMap mkModuleDepFFI1 ps) <> mkModuleDepFFI1 y - in nub (filter (/= y) alldeps') -mkModuleDepFFI (Left _) = [] - -- | Find module-level dependency per each toplevel function/template function. -mkTopLevelDep :: - TopLevel -> - [ Either - (TemplateClassModuleType, TemplateClass) - (ClassModuleType, Class) - ] +mkTopLevelDep :: TopLevel -> [UClassSubmodule] mkTopLevelDep (TLOrdinary f) = let dep4func = extractClassDepForTLOrdinary f allDeps = returnDependency dep4func ++ argumentDependency dep4func - mkTags (Left tcl) = [Left (TCMTTemplate, tcl)] - mkTags (Right cls) = fmap (Right . (,cls)) [CMTRawType, CMTCast, CMTInterface] + mkTags (Left tcl) = [Left (TCSTTemplate, tcl)] + mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface] in concatMap mkTags allDeps mkTopLevelDep (TLTemplate f) = let dep4func = extractClassDepForTLTemplate f allDeps = returnDependency dep4func ++ argumentDependency dep4func - mkTags (Left tcl) = [Left (TCMTTemplate, tcl)] - mkTags (Right cls) = fmap (Right . (,cls)) [CMTRawType, CMTCast, CMTInterface] + mkTags (Left tcl) = [Left (TCSTTemplate, tcl)] + mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface] in concatMap mkTags allDeps -- | @@ -342,18 +362,12 @@ mkClassModule getImports extra c = ClassModule { cmModule = getClassModuleBase c, cmCIH = mkCIH getImports c, - cmImportedModulesExternal = exts, - cmImportedModulesRaw = raws, - cmImportedModulesInplace = inplaces, - cmImportedModulesFFI = ffis, - cmExtraImport = extraimports + cmImportedSubmodulesForInterface = calculateDependency $ Right (CSTInterface, c), + cmImportedSubmodulesForFFI = calculateDependency $ Right (CSTFFI, c), + cmImportedSubmodulesForCast = calculateDependency $ Right (CSTCast, c), + cmImportedSubmodulesForImplementation = calculateDependency $ Right (CSTImplementation, c), + cmExtraImport = fromMaybe [] (lookup (class_name c) extra) } - where - exts = mkModuleDepExternal (Right c) - raws = mkModuleDepRaw (Right c) - inplaces = mkModuleDepInplace (Right c) - ffis = mkModuleDepFFI (Right c) - extraimports = fromMaybe [] (lookup (class_name c) extra) -- | findModuleUnitImports :: ModuleUnitMap -> ModuleUnit -> ModuleUnitImports @@ -379,7 +393,7 @@ mkPackageConfig :: mkPackageConfig (pkgname, getImports) (cs, fs, ts, extra) acincs acsrcs = let ms = map (mkClassModule getImports extra) cs cmpfunc x y = class_name (cihClass x) == class_name (cihClass y) - cihs = nubBy cmpfunc (map cmCIH ms) + cihs = L.nubBy cmpfunc (map cmCIH ms) -- tih = mkTIH pkgname getImports cihs fs tcms = map mkTCM ts @@ -394,13 +408,6 @@ mkPackageConfig (pkgname, getImports) (cs, fs, ts, extra) acincs acsrcs = pcfg_additional_c_srcs = acsrcs } -mkHsBootCandidateList :: [ClassModule] -> [ClassModule] -mkHsBootCandidateList ms = - let -- get only class dependencies, not template classes. - cs = rights (concatMap cmImportedModulesInplace ms) - candidateModBases = fmap getClassModuleBase cs - in filter (\m -> cmModule m `elem` candidateModBases) ms - -- | mkPkgHeaderFileName :: Class -> HeaderName mkPkgHeaderFileName c = @@ -422,7 +429,7 @@ mkPkgIncludeHeadersInH :: Class -> [HeaderName] mkPkgIncludeHeadersInH c = let pkgname = (cabal_pkgname . class_cabal) c extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c - extheaders = nub . map ((<> "Type.h") . unCabalName . getPkgName) $ extclasses + extheaders = L.nub . map ((<> "Type.h") . unCabalName . getPkgName) $ extclasses in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders -- | @@ -458,20 +465,20 @@ mkTIH pkgname getImports cihs fs = let ofs = filterTLOrdinary fs tl_cs1 = concatMap (argumentDependency . extractClassDepForTLOrdinary) ofs tl_cs2 = concatMap (returnDependency . extractClassDepForTLOrdinary) ofs - tl_cs = nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2) + tl_cs = L.nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2) -- NOTE: Select only class dependencies in the current package. -- TODO: This is clearly not a good impl. we need to look into this again -- after reconsidering multi-package generation. tl_cihs = catMaybes (foldr fn [] tl_cs) where fn c ys = - let y = find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs + let y = L.find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs in y : ys -- NOTE: The remaining class dependencies outside the current package extclasses = filter ((/= pkgname) . getPkgName) tl_cs extheaders = map HdrName $ - nub $ + L.nub $ map ((<> "Type.h") . unCabalName . getPkgName) extclasses in TopLevelImportHeader { tihHeaderFileName = unCabalName pkgname <> "TopLevel", diff --git a/fficxx/src/FFICXX/Generate/Dependency/Graph.hs b/fficxx/src/FFICXX/Generate/Dependency/Graph.hs new file mode 100644 index 00000000..7e106854 --- /dev/null +++ b/fficxx/src/FFICXX/Generate/Dependency/Graph.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module FFICXX.Generate.Dependency.Graph where + +import Data.Array (listArray) +import qualified Data.Graph as G +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Tree (flatten) +import Data.Tuple (swap) +import FFICXX.Generate.Dependency + ( calculateDependency, + mkTopLevelDep, + ) +import FFICXX.Generate.Name (subModuleName) +import FFICXX.Generate.Type.Class (TopLevel (..)) +import FFICXX.Generate.Type.Module + ( ClassSubmoduleType (..), + DepCycles, + TemplateClassSubmoduleType (..), + UClass, + UClassSubmodule, + ) + +-- TODO: Introduce unique id per submodule. + +-- | construct dependency graph +constructDepGraph :: + -- | list of all classes, either template class or ordinary class. + [UClass] -> + -- | list of all top-level functions. + [TopLevel] -> + -- | (all submodules, [(submodule, submodule dependencies)]) + ([String], [(Int, [Int])]) +constructDepGraph allClasses allTopLevels = (allSyms, depmap') + where + -- for classes/template classes + mkDep :: UClass -> [(UClassSubmodule, [UClassSubmodule])] + mkDep c = + case c of + Left tcl -> + fmap + (build . Left . (,tcl)) + [TCSTTemplate, TCSTTH] + Right cls -> + fmap + (build . Right . (,cls)) + [CSTRawType, CSTFFI, CSTInterface, CSTCast, CSTImplementation] + where + build x = (x, calculateDependency x) + + dep2Name :: [(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])] + dep2Name = fmap (\(x, ys) -> (subModuleName x, fmap subModuleName ys)) + -- TopLevel + topLevelDeps :: (String, [String]) + topLevelDeps = + let deps = + L.nub . L.sort $ concatMap (fmap subModuleName . mkTopLevelDep) allTopLevels + in ("[TopLevel]", deps) + + depmapAllClasses = concatMap (dep2Name . mkDep) allClasses + depmap = topLevelDeps : depmapAllClasses + allSyms = + L.nub . L.sort $ + fmap fst depmap ++ concatMap snd depmap + allISyms :: [(Int, String)] + allISyms = zip [0 ..] allSyms + symRevMap = HM.fromList $ fmap swap allISyms + replace (c, ds) = do + i <- HM.lookup c symRevMap + js <- traverse (\d -> HM.lookup d symRevMap) ds + pure (i, js) + depmap' = mapMaybe replace depmap + +-- | find grouped dependency cycles +findDepCycles :: ([String], [(Int, [Int])]) -> DepCycles +findDepCycles (syms, deps) = + let symMap = zip [0 ..] syms + lookupSym i = fromMaybe "" (L.lookup i symMap) + n = length syms + bounds = (0, n - 1) + gr = listArray bounds $ fmap (\i -> fromMaybe [] (L.lookup i deps)) [0 .. n - 1] + lookupSymAndRestrictDeps :: [Int] -> [(String, ([String], [String]))] + lookupSymAndRestrictDeps cycl = fmap go cycl + where + go i = + let sym = lookupSym i + (rdepsU, rdepsL) = + L.partition (< i) $ filter (`elem` cycl) $ fromMaybe [] (L.lookup i deps) + (rdepsU', rdepsL') = (fmap lookupSym rdepsU, fmap lookupSym rdepsL) + in (sym, (rdepsU', rdepsL')) + cycleGroups = + fmap lookupSymAndRestrictDeps $ filter (\xs -> length xs > 1) $ fmap flatten (G.scc gr) + in cycleGroups + +getCyclicDepSubmodules :: String -> DepCycles -> ([String], [String]) +getCyclicDepSubmodules self depCycles = fromMaybe ([], []) $ do + cycl <- L.find (\xs -> self `L.elem` fmap fst xs) depCycles + L.lookup self cycl + +-- | locate importing module and imported module in dependency cycles +locateInDepCycles :: (String, String) -> DepCycles -> Maybe (Int, Int) +locateInDepCycles (self, imported) depCycles = do + cycl <- L.find (\xs -> self `L.elem` fmap fst xs) depCycles + let cyclNoDeps = fmap fst cycl + idxSelf <- self `L.elemIndex` cyclNoDeps + idxImported <- imported `L.elemIndex` cyclNoDeps + pure (idxSelf, idxImported) + +gatherHsBootSubmodules :: DepCycles -> [String] +gatherHsBootSubmodules depCycles = do + cycl <- depCycles + (_, (_us, ds)) <- cycl + d <- ds + pure d diff --git a/fficxx/src/FFICXX/Generate/Name.hs b/fficxx/src/FFICXX/Generate/Name.hs index a6d48189..5933e325 100644 --- a/fficxx/src/FFICXX/Generate/Name.hs +++ b/fficxx/src/FFICXX/Generate/Name.hs @@ -5,6 +5,7 @@ module FFICXX.Generate.Name where import Data.Char (toLower) import Data.Maybe (fromMaybe) +import FFICXX.Generate.Type.Cabal (cabal_moduleprefix) import FFICXX.Generate.Type.Class ( Accessor (..), Arg (..), @@ -20,18 +21,12 @@ import FFICXX.Generate.Type.Class TopLevel (..), Variable (..), ) +import FFICXX.Generate.Type.Module + ( ClassSubmoduleType (..), + TemplateClassSubmoduleType (..), + ) import FFICXX.Generate.Util (firstLower, toLowers) - -data ClassModuleType - = CMTRawType - | CMTInterface - | CMTImplementation - | CMTFFI - | CMTCast - -data TemplateClassModuleType - = TCMTTH - | TCMTTemplate +import System.FilePath ((<.>)) hsFrontNameForTopLevel :: TopLevel -> String hsFrontNameForTopLevel tfn = @@ -172,3 +167,35 @@ nonvirtualName c str = (firstLower . fst . hsClassName) c <> "_" <> str destructorName :: String destructorName = "delete" + +-- +-- Module base and Submodule names in ClassModule +-- + +getClassModuleBase :: Class -> String +getClassModuleBase = (<.>) <$> (cabal_moduleprefix . class_cabal) <*> (fst . hsClassName) + +getTClassModuleBase :: TemplateClass -> String +getTClassModuleBase = (<.>) <$> (cabal_moduleprefix . tclass_cabal) <*> (fst . hsTemplateClassName) + +subModuleName :: + Either + (TemplateClassSubmoduleType, TemplateClass) + (ClassSubmoduleType, Class) -> + String +subModuleName (Left (typ, tcl)) = modBase <.> submod + where + modBase = getTClassModuleBase tcl + submod = case typ of + TCSTTH -> "TH" + TCSTTemplate -> "Template" +subModuleName (Right (typ, cls)) = modBase <.> submod + where + modBase = getClassModuleBase cls + submod = + case typ of + CSTRawType -> "RawType" + CSTInterface -> "Interface" + CSTImplementation -> "Implementation" + CSTFFI -> "FFI" + CSTCast -> "Cast" diff --git a/fficxx/src/FFICXX/Generate/Type/Module.hs b/fficxx/src/FFICXX/Generate/Type/Module.hs index 722c3b90..f843a9f9 100644 --- a/fficxx/src/FFICXX/Generate/Type/Module.hs +++ b/fficxx/src/FFICXX/Generate/Type/Module.hs @@ -5,7 +5,9 @@ import FFICXX.Generate.Type.Cabal (AddCInc, AddCSrc) import FFICXX.Generate.Type.Class (Class, TemplateClass, TopLevel) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) --- | C++ side +-- +-- Import/Header +-- -- HPkg is generated C++ headers by fficxx, CPkg is original C++ headers data ClassImportHeader = ClassImportHeader { cihClass :: Class, @@ -23,20 +25,49 @@ data ClassImportHeader = ClassImportHeader } deriving (Show) -------------------------- --- Haskell side module -- -------------------------- +-- +-- Submodule +-- + +data ClassSubmoduleType + = CSTRawType + | CSTInterface + | CSTImplementation + | CSTFFI + | CSTCast + deriving (Show) + +data TemplateClassSubmoduleType + = TCSTTH + | TCSTTemplate + deriving (Show) + +-- | UClass = Unified Class, either template class or ordinary class +type UClass = Either TemplateClass Class + +type UClassSubmodule = + Either (TemplateClassSubmoduleType, TemplateClass) (ClassSubmoduleType, Class) + +-- | Dependency cycle information. Currently just a string +-- self, former, latter +type DepCycles = [[(String, ([String], [String]))]] + +-- +-- Module +-- data ClassModule = ClassModule { cmModule :: String, cmCIH :: ClassImportHeader, - -- | imported modules external to the current package unit. - cmImportedModulesExternal :: [Either TemplateClass Class], - -- | imported modules for raw types. - cmImportedModulesRaw :: [Either TemplateClass Class], - -- | imported modules in the current package-in-place - cmImportedModulesInplace :: [Either TemplateClass Class], - cmImportedModulesFFI :: [Either TemplateClass Class], + -- | imported submodules for Interface.hs + cmImportedSubmodulesForInterface :: [UClassSubmodule], + -- | imported submodules for FFI.hs + cmImportedSubmodulesForFFI :: [UClassSubmodule], + -- | imported submodules for Cast.hs + cmImportedSubmodulesForCast, + -- imported submodules for Implementation.hs + cmImportedSubmodulesForImplementation :: + [UClassSubmodule], cmExtraImport :: [String] } deriving (Show) @@ -67,6 +98,10 @@ data TopLevelImportHeader = TopLevelImportHeader } deriving (Show) +-- +-- Package-level +-- + data PackageConfig = PkgConfig { pcfg_classModules :: [ClassModule], pcfg_classImportHeaders :: [ClassImportHeader], diff --git a/fficxx/src/FFICXX/Generate/Util/DepGraph.hs b/fficxx/src/FFICXX/Generate/Util/DepGraph.hs index 57522cfb..b6a44524 100644 --- a/fficxx/src/FFICXX/Generate/Util/DepGraph.hs +++ b/fficxx/src/FFICXX/Generate/Util/DepGraph.hs @@ -1,36 +1,14 @@ -{-# LANGUAGE LambdaCase #-} - module FFICXX.Generate.Util.DepGraph ( drawDepGraph, ) where import Data.Foldable (for_) -import qualified Data.HashMap.Strict as HM -import qualified Data.List as L -import Data.Maybe (mapMaybe) -import Data.Tuple (swap) -import FFICXX.Generate.Dependency - ( class_allparents, - mkModuleDepExternal, - mkModuleDepFFI, - mkModuleDepInplace, - mkModuleDepRaw, - mkTopLevelDep, - ) -import FFICXX.Generate.Name - ( ClassModuleType (..), - TemplateClassModuleType (..), - hsClassName, - hsTemplateClassName, - ) -import FFICXX.Generate.Type.Class - ( Class (..), - TemplateClass (..), - TopLevel (..), +import FFICXX.Generate.Dependency.Graph + ( constructDepGraph, ) -import System.FilePath ((<.>)) -import System.IO (IOMode (..), hPutStrLn, withFile) +import FFICXX.Generate.Type.Class (TopLevel (..)) +import FFICXX.Generate.Type.Module (UClass) import Text.Dot (Dot, NodeId, attribute, node, showDot, (.->.)) src, box, diamond :: String -> Dot NodeId @@ -38,31 +16,6 @@ src label = node $ [("shape", "none"), ("label", label)] box label = node $ [("shape", "box"), ("style", "rounded"), ("label", label)] diamond label = node $ [("shape", "diamond"), ("label", label), ("fontsize", "10")] --- TODO: Should be used everywhere. - --- | UClass = Unified Class, either template class or ordinary class -type UClass = Either TemplateClass Class - -formatOrdinary :: ClassModuleType -> Class -> String -formatOrdinary typ cls = highName <.> submod - where - (highName, _rawName) = hsClassName cls - submod = - case typ of - CMTRawType -> "RawType" - CMTInterface -> "Interface" - CMTImplementation -> "Implementation" - CMTFFI -> "FFI" - CMTCast -> "Cast" - -formatTemplate :: TemplateClassModuleType -> TemplateClass -> String -formatTemplate typ tcl = "<" ++ highName <.> submod ++ ">" - where - (highName, _rawName) = hsTemplateClassName tcl - submod = case typ of - TCMTTH -> "TH" - TCMTTemplate -> "Template" - -- | Draw dependency graph of modules in graphviz dot format. drawDepGraph :: -- | list of all classes, either template class or ordinary class. @@ -80,129 +33,4 @@ drawDepGraph allclasses allTopLevels = for_ js $ \j -> (cs !! i) .->. (cs !! j) where - -- RawType dependency is trivial - mkRawTypeDep :: Class -> (String, [String]) - mkRawTypeDep c = - let rawtype = formatOrdinary CMTRawType c - in (rawtype, []) - -- FFI - mkFFIDep :: Class -> (String, [String]) - mkFFIDep c = - let ffi = formatOrdinary CMTFFI c - depRawSelf = formatOrdinary CMTRawType c - depsFFI = - let ds = mkModuleDepFFI (Right c) - format' (Left tcl) = formatTemplate TCMTTemplate tcl - format' (Right cls) = formatOrdinary CMTRawType cls - in fmap format' ds - in (ffi, [depRawSelf] ++ depsFFI) - mkInterfaceDep :: Class -> (String, [String]) - mkInterfaceDep c = - let interface = formatOrdinary CMTInterface c - depRawSelf = formatOrdinary CMTRawType c - depsRaw = - let ds = mkModuleDepRaw (Right c) - format' (Left tcl) = formatTemplate TCMTTemplate tcl - format' (Right cls) = formatOrdinary CMTRawType cls - in fmap format' ds - depsExt = - let ds = mkModuleDepExternal (Right c) - format' (Left tcl) = formatTemplate TCMTTemplate tcl - format' (Right cls) = formatOrdinary CMTInterface cls - in fmap format' ds - depsInplace = - let ds = mkModuleDepInplace (Right c) - format' (Left tcl) = formatTemplate TCMTTemplate tcl - format' (Right cls) = formatOrdinary CMTInterface cls - in fmap format' ds - in (interface, [depRawSelf] ++ depsRaw ++ depsExt ++ depsInplace) - -- Cast - mkCastDep :: Class -> (String, [String]) - mkCastDep c = - let cast = formatOrdinary CMTCast c - depsSelf = [formatOrdinary CMTRawType c, formatOrdinary CMTInterface c] - in (cast, depsSelf) - -- Implementation - -- TODO: THIS IS INVOLVED! NEED TO REFACTOR THINGS OUT. - mkImplementationDep :: Class -> (String, [String]) - mkImplementationDep c = - let implementation = formatOrdinary CMTImplementation c - depsSelf = - [ formatOrdinary CMTRawType c, - formatOrdinary CMTFFI c, - formatOrdinary CMTInterface c, - formatOrdinary CMTCast c - ] - deps = - let dsFFI = mkModuleDepFFI (Right c) - dsParents = L.nub $ map Right $ class_allparents c - dsNonParents = filter (not . (flip elem dsParents)) dsFFI - format (Left tcl) = [formatTemplate TCMTTemplate tcl] - format (Right cls) = - fmap (\typ -> formatOrdinary typ cls) [CMTRawType, CMTCast, CMTInterface] - in concatMap format (dsNonParents ++ dsParents) - in (implementation, depsSelf ++ deps) - -- Template Class part - -- .Template - mkTemplateDep :: TemplateClass -> (String, [String]) - mkTemplateDep t = - let template = formatTemplate TCMTTemplate t - depsRaw = - let ds = mkModuleDepRaw (Left t) - format' (Left tcl) = formatTemplate TCMTTemplate tcl - format' (Right cls) = formatOrdinary CMTRawType cls - in fmap format' ds - depsInplace = - let ds = mkModuleDepInplace (Left t) - format' (Left tcl) = formatTemplate TCMTTemplate tcl - format' (Right cls) = formatOrdinary CMTInterface cls - in fmap format' ds - in (template, depsRaw ++ depsInplace) - -- .TH - mkTHDep :: TemplateClass -> (String, [String]) - mkTHDep t = - let th = formatTemplate TCMTTH t - deps = - let dsRaw = mkModuleDepRaw (Left t) - dsInplace = mkModuleDepInplace (Left t) - - format' (Left tcl) = [formatTemplate TCMTTemplate tcl] - format' (Right cls) = - fmap (\typ -> formatOrdinary typ cls) [CMTRawType, CMTCast, CMTInterface] - in concatMap format' (dsRaw ++ dsInplace) - in (th, deps) - -- TopLevel - topLevelDeps :: (String, [String]) - topLevelDeps = - let format' (Left (typ, tcl)) = formatTemplate typ tcl - format' (Right (typ, cls)) = formatOrdinary typ cls - deps = - L.nub . L.sort $ concatMap (fmap format' . mkTopLevelDep) allTopLevels - in ("[TopLevel]", deps) - - depmapAllClasses = - concatMap - ( \case - Left tcl -> [mkTemplateDep tcl] - Right cls -> - [ mkRawTypeDep cls, - mkFFIDep cls, - mkInterfaceDep cls, - mkCastDep cls, - mkImplementationDep cls - ] - ) - allclasses - depmap = topLevelDeps : depmapAllClasses - allSyms = - L.nub . L.sort $ - fmap fst depmap ++ concatMap snd depmap - allISyms :: [(Int, String)] - allISyms = zip [0 ..] allSyms - symMap = HM.fromList allISyms - symRevMap = HM.fromList $ fmap swap allISyms - replace (c, ds) = do - i <- HM.lookup c symRevMap - js <- traverse (\d -> HM.lookup d symRevMap) ds - pure (i, js) - depmap' = mapMaybe replace depmap + (allSyms, depmap') = constructDepGraph allclasses allTopLevels