{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module FFICXX.Generate.ContentMaker where import Control.Lens (at, (&), (.~)) import Control.Monad.Trans.Reader (runReader) import Data.Either (rights) import Data.Functor.Identity (Identity) import Data.List (intercalate, nub) import qualified Data.Map as M import Data.Maybe (mapMaybe) import FFICXX.Generate.Code.Cpp ( genAllCppHeaderInclude, genCppDefInstAccessor, genCppDefInstNonVirtual, genCppDefInstVirtual, genCppDefMacroAccessor, genCppDefMacroNonVirtual, genCppDefMacroTemplateMemberFunction, genCppDefMacroVirtual, genCppHeaderInstAccessor, genCppHeaderInstNonVirtual, genCppHeaderInstVirtual, genCppHeaderMacroAccessor, genCppHeaderMacroNonVirtual, genCppHeaderMacroType, genCppHeaderMacroVirtual, genTopLevelCppDefinition, topLevelDecl, ) import FFICXX.Generate.Code.HsCast ( genHsFrontInstCastable, genHsFrontInstCastableSelf, ) import FFICXX.Generate.Code.HsFFI ( genHsFFI, genImportInFFI, genTopLevelFFI, ) import FFICXX.Generate.Code.HsFrontEnd ( genExport, genExtraImport, genHsFrontDecl, genHsFrontDowncastClass, genHsFrontInst, genHsFrontInstNew, genHsFrontInstNonVirtual, genHsFrontInstStatic, genHsFrontInstVariables, genHsFrontUpcastClass, genImportForTLOrdinary, genImportForTLTemplate, genImportInCast, genImportInImplementation, genImportInInterface, genImportInModule, genImportInTopLevel, genTopLevelDef, hsClassRawType, ) import FFICXX.Generate.Code.HsProxy (genProxyInstance) import FFICXX.Generate.Code.HsTemplate ( genImportInTH, genImportInTemplate, genTLTemplateImplementation, genTLTemplateInstance, genTLTemplateInterface, genTemplateMemberFunctions, genTmplImplementation, genTmplInstance, genTmplInterface, ) import FFICXX.Generate.Dependency ( class_allparents, mkDaughterMap, mkDaughterSelfMap, ) import FFICXX.Generate.Name ( ffiClassName, hsClassName, hsFrontNameForTopLevel, ) import FFICXX.Generate.Type.Annotate (AnnotateMap) import FFICXX.Generate.Type.Class ( Class (..), ClassGlobal (..), DaughterMap, ProtectedMethod (..), TopLevel (TLOrdinary, TLTemplate), filterTLOrdinary, filterTLTemplate, isAbstractClass, ) import FFICXX.Generate.Type.Module ( ClassImportHeader (..), ClassModule (..), DepCycles, TemplateClassImportHeader (..), TemplateClassModule (..), TopLevelImportHeader (..), ) import FFICXX.Generate.Type.PackageInterface ( ClassName (..), PackageInterface, PackageName (..), ) import FFICXX.Generate.Util (firstUpper) import FFICXX.Generate.Util.HaskellSrcExts ( emodule, evar, lang, mkImport, mkModule, mkModuleE, unqual, ) import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) import qualified FFICXX.Runtime.CodeGen.Cxx as R import Language.Haskell.Exts.Syntax ( Decl (..), EWildcard (EWildcard), ExportSpec (EThingWith), Module (..), ) import System.FilePath ((<.>), ()) srcDir :: FilePath -> FilePath srcDir installbasedir = installbasedir "src" csrcDir :: FilePath -> FilePath csrcDir installbasedir = installbasedir "csrc" ---- common function for daughter -- | mkGlobal :: [Class] -> ClassGlobal mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap -- | buildDaughterDef :: ((String, [Class]) -> String) -> DaughterMap -> String buildDaughterDef f m = let lst = M.toList m f' (x, xs) = f (x, filter (not . isAbstractClass) xs) in (concatMap f' lst) -- | buildParentDef :: ((Class, Class) -> [R.CStatement Identity]) -> Class -> [R.CStatement Identity] buildParentDef f cls = concatMap (\p -> f (p, cls)) . class_allparents $ cls -- | mkProtectedFunctionList :: Class -> [R.CMacro Identity] mkProtectedFunctionList c = map (\x -> R.Define (R.sname ("IS_" <> class_name c <> "_" <> x <> "_PROTECTED")) [] [R.CVerbatim "()"]) . unProtected . class_protected $ c -- | buildTypeDeclHeader :: [Class] -> String buildTypeDeclHeader classes = let typeDeclBodyStmts = intercalate [R.EmptyLine] $ map (map R.CRegular . genCppHeaderMacroType) classes in R.renderBlock $ R.ExternC $ [R.Pragma R.Once, R.EmptyLine] <> typeDeclBodyStmts -- | buildDeclHeader :: -- | C prefix String -> ClassImportHeader -> String buildDeclHeader cprefix header = let classes = [cihClass header] aclass = cihClass header declHeaderStmts = [R.Include (HdrName (cprefix ++ "Type.h"))] <> map R.Include (cihIncludedHPkgHeadersInH header) vdecl = map genCppHeaderMacroVirtual classes nvdecl = map genCppHeaderMacroNonVirtual classes acdecl = map genCppHeaderMacroAccessor classes vdef = map genCppDefMacroVirtual classes nvdef = map genCppDefMacroNonVirtual classes acdef = map genCppDefMacroAccessor classes tmpldef = map (\c -> map (genCppDefMacroTemplateMemberFunction c) (class_tmpl_funcs c)) classes declDefStmts = intercalate [R.EmptyLine] $ [vdecl, nvdecl, acdecl, vdef, nvdef, acdef] ++ tmpldef classDeclStmts = -- NOTE: Deletable is treated specially. -- TODO: We had better make it as a separate constructor in Class. if (fst . hsClassName) aclass /= "Deletable" then buildParentDef (\(p, c) -> [genCppHeaderInstVirtual (p, c), R.CEmptyLine]) aclass <> [genCppHeaderInstVirtual (aclass, aclass), R.CEmptyLine] <> concatMap (\c -> [genCppHeaderInstNonVirtual c, R.CEmptyLine]) classes <> concatMap (\c -> [genCppHeaderInstAccessor c, R.CEmptyLine]) classes else [] in R.renderBlock $ R.ExternC $ [R.Pragma R.Once, R.EmptyLine] <> declHeaderStmts <> [R.EmptyLine] <> declDefStmts <> [R.EmptyLine] <> map R.CRegular classDeclStmts -- | buildDefMain :: ClassImportHeader -> String buildDefMain cih = let classes = [cihClass cih] headerStmts = [R.Include "MacroPatternMatch.h"] <> genAllCppHeaderInclude cih <> [R.Include (cihSelfHeader cih)] namespaceStmts = (map R.UsingNamespace . cihNamespace) cih aclass = cihClass cih aliasStr = intercalate "\n" $ mapMaybe typedefstmt $ aclass : rights (cihImportedClasses cih) where typedefstmt c = let n1 = class_name c n2 = ffiClassName c in if n1 == n2 then Nothing else Just ("typedef " <> n1 <> " " <> n2 <> ";") cppBodyStmts = mkProtectedFunctionList (cihClass cih) <> map R.CRegular ( buildParentDef (\(p, c) -> [genCppDefInstVirtual (p, c), R.CEmptyLine]) (cihClass cih) <> ( if isAbstractClass aclass then [] else [genCppDefInstVirtual (aclass, aclass), R.CEmptyLine] ) <> concatMap (\c -> [genCppDefInstNonVirtual c, R.CEmptyLine]) classes <> concatMap (\c -> [genCppDefInstAccessor c, R.CEmptyLine]) classes ) in concatMap R.renderCMacro ( headerStmts <> [R.EmptyLine] <> map R.CRegular namespaceStmts <> [ R.EmptyLine, R.Verbatim aliasStr, R.EmptyLine, R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n", R.EmptyLine, R.Verbatim "#define TYPECASTMETHOD(cname,mname,oname) \\\n\ \ FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\ \ (from_nonconst_to_nonconst), \\\n\ \ (from_nonconst_to_nonconst) )\n", R.EmptyLine ] <> cppBodyStmts ) -- | buildTopLevelHeader :: -- | C prefix String -> TopLevelImportHeader -> String buildTopLevelHeader cprefix tih = let declHeaderStmts = [R.Include (HdrName (cprefix ++ "Type.h"))] <> map R.Include (map cihSelfHeader (tihClassDep tih) ++ tihExtraHeadersInH tih) declBodyStmts = map (R.CDeclaration . topLevelDecl) $ filterTLOrdinary (tihFuncs tih) in R.renderBlock $ R.ExternC $ [R.Pragma R.Once, R.EmptyLine] <> declHeaderStmts <> [R.EmptyLine] <> map R.CRegular declBodyStmts -- | buildTopLevelCppDef :: TopLevelImportHeader -> String buildTopLevelCppDef tih = let cihs = tihClassDep tih extclasses = tihExtraClassDep tih declHeaderStmts = [ R.Include "MacroPatternMatch.h", R.Include (HdrName (tihHeaderFileName tih <.> "h")) ] <> concatMap genAllCppHeaderInclude cihs <> otherHeaderStmts otherHeaderStmts = map R.Include (map cihSelfHeader cihs ++ tihExtraHeadersInCPP tih) allns = nub ((tihClassDep tih >>= cihNamespace) ++ tihNamespaces tih) namespaceStmts = map R.UsingNamespace allns aliasStr = intercalate "\n" $ mapMaybe typedefstmt $ rights (concatMap cihImportedClasses cihs ++ extclasses) where typedefstmt c = let n1 = class_name c n2 = ffiClassName c in if n1 == n2 then Nothing else Just ("typedef " <> n1 <> " " <> n2 <> ";") declBodyStr = intercalate "\n" $ map (R.renderCStmt . genTopLevelCppDefinition) $ filterTLOrdinary (tihFuncs tih) in concatMap R.renderCMacro ( declHeaderStmts <> [R.EmptyLine] <> map R.CRegular namespaceStmts <> [ R.EmptyLine, R.Verbatim aliasStr, R.EmptyLine, R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n", R.EmptyLine, R.Verbatim "#define TYPECASTMETHOD(cname,mname,oname) \\\n\ \ FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\ \ (to_nonconst), \\\n\ \ (to_nonconst) )\n", R.EmptyLine, R.Verbatim declBodyStr ] ) -- | buildFFIHsc :: ClassModule -> Module () buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface", "InterruptibleFFI"]] ffiImports hscBody where mname = cmModule m ffiImports = [ mkImport "Data.Word", mkImport "Data.Int", mkImport "Foreign.C", mkImport "Foreign.Ptr", mkImport (mname <.> "RawType") ] <> genImportInFFI m <> genExtraImport m hscBody = genHsFFI (cmCIH m) -- | buildRawTypeHs :: ClassModule -> Module () buildRawTypeHs m = mkModule (cmModule m <.> "RawType") [ lang [ "ForeignFunctionInterface", "TypeFamilies", "MultiParamTypeClasses", "FlexibleInstances", "TypeSynonymInstances", "EmptyDataDecls", "ExistentialQuantification", "ScopedTypeVariables" ] ] rawtypeImports rawtypeBody where rawtypeImports = [ mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] rawtypeBody = let c = cihClass (cmCIH m) in if isAbstractClass c then [] else hsClassRawType c -- | buildInterfaceHs :: AnnotateMap -> DepCycles -> ClassModule -> Module () buildInterfaceHs amap depCycles m = mkModule (cmModule m <.> "Interface") [ lang [ "EmptyDataDecls", "ExistentialQuantification", "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface", "MultiParamTypeClasses", "ScopedTypeVariables", "TypeFamilies", "TypeSynonymInstances" ] ] ifaceImports ifaceBody where classes = [cihClass (cmCIH m)] ifaceImports = [ mkImport "Data.Word", mkImport "Data.Int", mkImport "Foreign.C", mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface False depCycles m <> genExtraImport m ifaceBody = runReader (mapM (genHsFrontDecl False) classes) amap <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes -- | buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module () buildInterfaceHsBoot depCycles m = mkModule (cmModule m <.> "Interface") [ lang [ "EmptyDataDecls", "ExistentialQuantification", "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface", "MultiParamTypeClasses", "ScopedTypeVariables", "TypeFamilies", "TypeSynonymInstances" ] ] hsbootImports hsbootBody where c = cihClass (cmCIH m) hsbootImports = [ mkImport "Data.Word", mkImport "Data.Int", mkImport "Foreign.C", mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface True depCycles m <> genExtraImport m hsbootBody = runReader (mapM (genHsFrontDecl True) [c]) M.empty -- | buildCastHs :: ClassModule -> Module () buildCastHs m = mkModule (cmModule m <.> "Cast") [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies", "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ] castImports body where classes = [cihClass (cmCIH m)] castImports = [ mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast", mkImport "System.IO.Unsafe" ] <> genImportInCast m body = mapMaybe genHsFrontInstCastable classes <> mapMaybe genHsFrontInstCastableSelf classes -- | buildImplementationHs :: AnnotateMap -> ClassModule -> Module () buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation") [ lang [ "EmptyDataDecls", "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface", "IncoherentInstances", "MultiParamTypeClasses", "OverlappingInstances", "TemplateHaskell", "TypeFamilies", "TypeSynonymInstances" ] ] implImports implBody where classes = [cihClass (cmCIH m)] implImports = [ mkImport "Data.Monoid", -- for template member mkImport "Data.Word", mkImport "Data.Int", mkImport "Foreign.C", mkImport "Foreign.Ptr", mkImport "Language.Haskell.TH", -- for template member mkImport "Language.Haskell.TH.Syntax", -- for template member mkImport "System.IO.Unsafe", mkImport "FFICXX.Runtime.Cast", mkImport "FFICXX.Runtime.CodeGen.Cxx", -- for template member mkImport "FFICXX.Runtime.TH" -- for template member ] <> genImportInImplementation m <> genExtraImport m f :: Class -> [Decl ()] f y = concatMap (flip genHsFrontInst y) (y : class_allparents y) implBody = concatMap f classes <> runReader (concat <$> mapM genHsFrontInstNew classes) amap <> concatMap genHsFrontInstNonVirtual classes <> concatMap genHsFrontInstStatic classes <> concatMap genHsFrontInstVariables classes <> genTemplateMemberFunctions (cmCIH m) buildProxyHs :: ClassModule -> Module () buildProxyHs m = mkModule (cmModule m <.> "Proxy") [ lang [ "FlexibleInstances", "OverloadedStrings", "TemplateHaskell" ] ] [ mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast", mkImport "Language.Haskell.TH", mkImport "Language.Haskell.TH.Syntax", mkImport "FFICXX.Runtime.CodeGen.Cxx" ] body where body = genProxyInstance buildTemplateHs :: TemplateClassModule -> Module () buildTemplateHs m = mkModule (tcmModule m <.> "Template") [ lang [ "EmptyDataDecls", "FlexibleInstances", "MultiParamTypeClasses", "TypeFamilies" ] ] imports body where t = tcihTClass $ tcmTCIH m imports = [ mkImport "Foreign.C.Types", mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] <> genImportInTemplate t body = genTmplInterface t buildTHHs :: TemplateClassModule -> Module () buildTHHs m = mkModule (tcmModule m <.> "TH") [lang ["TemplateHaskell"]] ( [ mkImport "Data.Char", mkImport "Data.List", mkImport "Data.Monoid", mkImport "Foreign.C.Types", mkImport "Foreign.Ptr", mkImport "Language.Haskell.TH", mkImport "Language.Haskell.TH.Syntax", mkImport "FFICXX.Runtime.CodeGen.Cxx", mkImport "FFICXX.Runtime.TH" ] <> imports ) body where t = tcihTClass $ tcmTCIH m imports = [mkImport (tcmModule m <.> "Template")] <> genImportInTH t body = tmplImpls <> tmplInsts tmplImpls = genTmplImplementation t tmplInsts = genTmplInstance (tcmTCIH m) -- | buildModuleHs :: ClassModule -> Module () buildModuleHs m = mkModuleE (cmModule m) [] (genExport c) (genImportInModule c) [] where c = cihClass (cmCIH m) -- | buildTopLevelHs :: String -> ([ClassModule], [TemplateClassModule]) -> Module () buildTopLevelHs modname (mods, tmods) = mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody where pkgExtensions = [ lang [ "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface", "InterruptibleFFI" ] ] pkgExports = map (emodule . cmModule) mods ++ map emodule [modname <.> "Ordinary", modname <.> "Template", modname <.> "TH"] pkgImports = genImportInTopLevel modname (mods, tmods) pkgBody = [] -- map (genTopLevelFFI tih) (filterTLOrdinary tfns) -- ++ concatMap genTopLevelDef (filterTLOrdinary tfns) buildTopLevelOrdinaryHs :: String -> ([ClassModule], [TemplateClassModule]) -> TopLevelImportHeader -> Module () buildTopLevelOrdinaryHs modname (_mods, tmods) tih = mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody where tfns = tihFuncs tih pkgExtensions = [ lang [ "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface", "InterruptibleFFI" ] ] pkgExports = map (evar . unqual . hsFrontNameForTopLevel . TLOrdinary) (filterTLOrdinary tfns) pkgImports = map mkImport ["Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast"] ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods ++ concatMap genImportForTLOrdinary (filterTLOrdinary tfns) pkgBody = map (genTopLevelFFI tih) (filterTLOrdinary tfns) ++ concatMap genTopLevelDef (filterTLOrdinary tfns) -- | buildTopLevelTemplateHs :: String -> TopLevelImportHeader -> Module () buildTopLevelTemplateHs modname tih = mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody where tfns = filterTLTemplate (tihFuncs tih) pkgExtensions = [ lang [ "EmptyDataDecls", "FlexibleInstances", "ForeignFunctionInterface", "InterruptibleFFI", "MultiParamTypeClasses", "TypeFamilies" ] ] pkgExports = map ( (\n -> EThingWith () (EWildcard () 1) n []) . unqual . firstUpper . hsFrontNameForTopLevel . TLTemplate ) tfns pkgImports = [ mkImport "Foreign.C.Types", mkImport "Foreign.Ptr", mkImport "FFICXX.Runtime.Cast" ] ++ concatMap genImportForTLTemplate tfns pkgBody = concatMap genTLTemplateInterface tfns -- | buildTopLevelTHHs :: String -> TopLevelImportHeader -> Module () buildTopLevelTHHs modname tih = mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody where tfns = filterTLTemplate (tihFuncs tih) pkgExtensions = [ lang [ "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface", "InterruptibleFFI", "TemplateHaskell" ] ] pkgExports = map ( evar . unqual . (\x -> "gen" <> x <> "InstanceFor") . firstUpper . hsFrontNameForTopLevel . TLTemplate ) tfns pkgImports = [ mkImport "Data.Char", mkImport "Data.List", mkImport "Data.Monoid", mkImport "Foreign.C.Types", mkImport "Foreign.Ptr", mkImport "Language.Haskell.TH", mkImport "Language.Haskell.TH.Syntax", mkImport "FFICXX.Runtime.CodeGen.Cxx", mkImport "FFICXX.Runtime.TH" ] ++ concatMap genImportForTLTemplate tfns pkgBody = concatMap genTLTemplateImplementation tfns <> concatMap (genTLTemplateInstance tih) tfns -- | buildPackageInterface :: PackageInterface -> PackageName -> [ClassImportHeader] -> PackageInterface buildPackageInterface pinfc pkgname = foldr f pinfc where f cih repo = let name = (class_name . cihClass) cih header = cihSelfHeader cih in repo & at (pkgname, ClsName name) .~ (Just header)