diff --git a/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -1,5 +1,5 @@ Name: fficxx -Version: 0.1.0 +Version: 0.2 Synopsis: automatic C++ binding generation Description: automatic C++ binding generation License: BSD3 @@ -21,6 +21,7 @@ sample/cxxlib/src/Makefile sample/mysample-generator/MySampleGen.hs sample/mysample-generator/use_mysample.hs + sample/snappy-generator/SnappyGen.hs Source-repository head @@ -51,6 +52,7 @@ Cabal Exposed-Modules: + FFICXX.Generate.Builder FFICXX.Generate.Type.Class FFICXX.Generate.Type.Module FFICXX.Generate.Type.PackageInterface diff --git a/lib/FFICXX/Generate/Builder.hs b/lib/FFICXX/Generate/Builder.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Builder.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Builder +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module FFICXX.Generate.Builder where + +import Data.Char (toUpper) +import Data.Monoid (mempty) +import System.FilePath (()) +import System.Directory (getCurrentDirectory) +import Text.StringTemplate hiding (render) +-- +import FFICXX.Generate.Code.Cabal +import FFICXX.Generate.Code.Cpp +import FFICXX.Generate.Code.Dependency +import FFICXX.Generate.Config +import FFICXX.Generate.Code.Cpp +import FFICXX.Generate.Code.Dependency +import FFICXX.Generate.Config +import FFICXX.Generate.Generator.ContentMaker +import FFICXX.Generate.Generator.Driver +import FFICXX.Generate.Type.Annotate +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.PackageInterface +import FFICXX.Generate.Util +-- +import qualified FFICXX.Paths_fficxx as F + +-- | +cabalTemplate :: String +cabalTemplate = "Pkg.cabal" + + +-- | +mkCabalFile :: FFICXXConfig + -> STGroup String + -> Cabal + -> (TopLevelImportHeader,[ClassModule]) + -> FilePath + -> IO () +mkCabalFile config templates cabal (tih,classmodules) cabalfile = do + cpath <- getCurrentDirectory + + let str = renderTemplateGroup + templates + [ ("pkgname", cabal_pkgname cabal) + , ("version", "0.0") + , ("license", "" ) + , ("buildtype", "Simple") + , ("deps", "" ) + , ("csrcFiles", genCsrcFiles (tih,classmodules)) + , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) classmodules) + , ("cppFiles", genCppFiles (tih,classmodules)) + , ("exposedModules", genExposedModules (cabal_pkgname cabal) classmodules) + , ("otherModules", genOtherModules classmodules) + , ("extralibdirs", "" ) + , ("extraincludedirs", "" ) + , ("extralib", ", snappy") + , ("cabalIndentation", cabalIndentation) + ] + cabalTemplate + writeFile cabalfile str + + +macrofy :: String -> String +macrofy = map ((\x->if x=='-' then '_' else x) . toUpper) + +simpleBuilder :: (Cabal,[Class],[TopLevelFunction]) -> IO () +simpleBuilder (cabal,myclasses, toplevelfunctions) = do + putStrLn "generate snappy" + cwd <- getCurrentDirectory + + let cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd + , fficxxconfig_workingDir = cwd "working" + , fficxxconfig_installBaseDir = cwd (cabal_pkgname cabal) + } + workingDir = fficxxconfig_workingDir cfg + installDir = fficxxconfig_installBaseDir cfg + pkgname = "Snappy" + (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH + ("Snappy", (const ([NS "snappy"],["snappy-sinksource.h","snappy.h"]))) + (myclasses, toplevelfunctions) + hsbootlst = mkHSBOOTCandidateList mods + cglobal = mkGlobal myclasses + summarymodule = "Snappy" + cabalFileName = "Snappy.cabal" + templateDir <- F.getDataDir >>= return . ( "template") + (templates :: STGroup String) <- directoryGroup templateDir + -- + notExistThenCreate workingDir + notExistThenCreate installDir + notExistThenCreate (installDir "src") + notExistThenCreate (installDir "csrc") + -- + putStrLn "cabal file generation" + mkCabalFile cfg templates cabal (tih,mods) (workingDir cabalFileName) + -- + putStrLn "header file generation" + let typmacro = TypMcro ("__" ++ macrofy (cabal_pkgname cabal) ++ "__") {- "__SNAPPY__" -} + writeTypeDeclHeaders templates workingDir typmacro pkgname cihs + mapM_ (writeDeclHeaders templates workingDir typmacro pkgname) cihs + writeTopLevelFunctionHeaders templates workingDir typmacro pkgname tih + -- + putStrLn "cpp file generation" + mapM_ (writeCppDef templates workingDir) cihs + writeTopLevelFunctionCppDef templates workingDir typmacro pkgname tih + -- + putStrLn "RawType.hs file generation" + mapM_ (writeRawTypeHs templates workingDir) mods + -- + putStrLn "FFI.hsc file generation" + mapM_ (writeFFIHsc templates workingDir) mods + -- + putStrLn "Interface.hs file generation" + mapM_ (writeInterfaceHs mempty templates workingDir) mods + -- + putStrLn "Cast.hs file generation" + mapM_ (writeCastHs templates workingDir) mods + -- + putStrLn "Implementation.hs file generation" + mapM_ (writeImplementationHs mempty templates workingDir) mods + -- + putStrLn "hs-boot file generation" + mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst + -- + putStrLn "module file generation" + mapM_ (writeModuleHs templates workingDir) mods + -- + putStrLn "summary module generation generation" + writePkgHs summarymodule templates workingDir mods tih + -- + putStrLn "copying" + copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) + -- copyPredefined templateDir (srcDir ibase) pkgname + copyCppFiles workingDir (csrcDir installDir) pkgname (tih,cihs) + mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods + + + diff --git a/lib/FFICXX/Generate/Code/Cpp.hs b/lib/FFICXX/Generate/Code/Cpp.hs --- a/lib/FFICXX/Generate/Code/Cpp.hs +++ b/lib/FFICXX/Generate/Code/Cpp.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cpp @@ -10,7 +12,6 @@ -- ----------------------------------------------------------------------------- - module FFICXX.Generate.Code.Cpp where import Data.Char @@ -32,17 +33,20 @@ ---- "Class Type Declaration" Instances genCppHeaderTmplType :: Class -> String -genCppHeaderTmplType c = let tmpl = "ROOT_TYPE_DECLARATION($classname$);" - in render tmpl [ ("classname", class_name c) ] +genCppHeaderTmplType c = let tmpl = "// Opaque type definition for $classname$ \n\ + \typedef struct $classname$_tag $classname$_t; \n\ + \typedef $classname$_t * $classname$_p; \n\ + \typedef $classname$_t const* const_$classname$_p; \n" + in render tmpl [ ("classname", class_name c) ] genAllCppHeaderTmplType :: [Class] -> String -genAllCppHeaderTmplType = intercalateWith connRet (genCppHeaderTmplType) +genAllCppHeaderTmplType = intercalateWith connRet2 (genCppHeaderTmplType) ---- "Class Declaration Virtual" Declaration genCppHeaderTmplVirtual :: Class -> String genCppHeaderTmplVirtual aclass = - let tmpl = "#undef ROOT_$classname$_DECLARATIONVIRT\\\n#define ROOT_$classname$_DECLARATIONVIRT(Type) \\\\\\\n$funcdecl$" + let tmpl = "#undef $classname$_DECL_VIRT\\\n#define $classname$_DECL_VIRT(Type) \\\\\\\n$funcdecl$" declBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) , ("funcdecl" , funcDeclStr ) ] funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass @@ -55,7 +59,7 @@ genCppHeaderTmplNonVirtual :: Class -> String genCppHeaderTmplNonVirtual c = - let tmpl = "#undef ROOT_$classname$_DECLARATIONNONVIRT\\\n#define ROOT_$classname$_DECLARATIONNONVIRT(Type) \\\\\\\n$funcdecl$" + let tmpl = "#undef $classname$_DECL_NONVIRT\\\n#define $classname$_DECL_NONVIRT(Type) \\\\\\\n$funcdecl$" declBodyStr = render tmpl [ ("classname", map toUpper (class_name c) ) , ("funcdecl" , funcDeclStr ) ] funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc) @@ -70,12 +74,12 @@ genCppHeaderInstVirtual :: (Class,Class) -> String genCppHeaderInstVirtual (p,c) = let strc = map toUpper (class_name p) - in "ROOT_"++strc++"_DECLARATIONVIRT(" ++ class_name c ++ ");\n" + in strc++"_DECL_VIRT(" ++ class_name c ++ ");\n" genCppHeaderInstNonVirtual :: Class -> String genCppHeaderInstNonVirtual c = let strx = map toUpper (class_name c) - in "ROOT_"++strx++"_DECLARATIONNONVIRT(" ++ class_name c ++ ");\n" + in strx++"_DECL_NONVIRT(" ++ class_name c ++ ");\n" genAllCppHeaderInstNonVirtual :: [Class] -> String genAllCppHeaderInstNonVirtual = @@ -90,7 +94,7 @@ genCppDefTmplVirtual :: Class -> String genCppDefTmplVirtual aclass = - let tmpl = "#undef ROOT_$classname$_DEFINITIONVIRT\\\n#define ROOT_$classname$_DEFINITIONVIRT(Type)\\\\\\\n$funcdef$" + let tmpl = "#undef $classname$_DEF_VIRT\\\n#define $classname$_DEF_VIRT(Type)\\\\\\\n$funcdef$" defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) , ("funcdef" , funcDefStr ) ] funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass @@ -103,7 +107,7 @@ genCppDefTmplNonVirtual :: Class -> String genCppDefTmplNonVirtual aclass = - let tmpl = "#undef ROOT_$classname$_DEFINITIONNONVIRT\\\n#define ROOT_$classname$_DEFINITIONNONVIRT(Type)\\\\\\\n$funcdef$" + let tmpl = "#undef $classname$_DEF_NONVIRT\\\n#define $classname$_DEF_NONVIRT(Type)\\\\\\\n$funcdef$" defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) , ("funcdef" , funcDefStr ) ] funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc) @@ -118,11 +122,11 @@ genCppDefInstVirtual :: (Class,Class) -> String genCppDefInstVirtual (p,c) = let strc = map toUpper (class_name p) - in "ROOT_"++strc++"_DEFINITIONVIRT(" ++ class_name c ++ ")\n" + in strc++"_DEF_VIRT(" ++ class_name c ++ ")\n" genCppDefInstNonVirtual :: Class -> String genCppDefInstNonVirtual c = - let tmpl = "ROOT_$capitalclassname$_DEFINITIONNONVIRT($classname$)" + let tmpl = "$capitalclassname$_DEF_NONVIRT($classname$)" in render tmpl [ ("capitalclassname", toUppers (class_name c)) , ("classname", class_name c) ] @@ -146,9 +150,6 @@ let strlst = map ((\x->"#include \""++x++"\"") . cihSelfHeader) headers in intercalate "\n" strlst ------ - - ---- genIncludeFiles :: String -- ^ package name @@ -164,8 +165,8 @@ includeFileStrs = map (\x->indent++x) selfheaders in unlines ((indent++pkgname++"Type.h") : includeFileStrs) -genCsrcFiles :: [ClassModule] -> String -genCsrcFiles cmods = +genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> String +genCsrcFiles (tih,cmods) = let indent = cabalIndentation selfheaders' = do x <- cmods @@ -177,19 +178,85 @@ y <- cmCIH x return (cihSelfCpp y) selfcpp = nub selfcpp' - includeFileStrsWithCsrc = map (\x->indent++"csrc"x) selfheaders - cppFilesWithCsrc = map (\x->indent++"csrc"x) selfcpp + tlh = tihHeaderFileName tih <.> "h" + tlcpp = tihHeaderFileName tih <.> "cpp" + includeFileStrsWithCsrc = map (\x->indent++"csrc"x) + (if (null.tihFuncs) tih then selfheaders else tlh:selfheaders) + cppFilesWithCsrc = map (\x->indent++"csrc"x) + (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) + in unlines (includeFileStrsWithCsrc ++ cppFilesWithCsrc) -genCppFiles :: [ClassModule] -> String -genCppFiles cmods = +genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> String +genCppFiles (tih,cmods) = let indent = cabalIndentation selfcpp' = do x <- cmods y <- cmCIH x return (cihSelfCpp y) selfcpp = nub selfcpp' - cppFileStrs = map (\x->indent++ "csrc" x) selfcpp + tlcpp = tihHeaderFileName tih <.> "cpp" + cppFileStrs = map (\x->indent++ "csrc" x) + (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) in unlines cppFileStrs + + + +------------------------- +-- TOP LEVEL FUNCTIONS -- +------------------------- + +genTopLevelFuncCppHeader :: TopLevelFunction -> String +genTopLevelFuncCppHeader TopLevelFunction {..} = + let tmpl = "$returntype$ $funcname$ ( $args$ );" + in render tmpl [ ("returntype", rettypeToString toplevelfunc_ret) + , ("funcname", "TopLevel_" + ++ maybe toplevelfunc_name id toplevelfunc_alias) + , ("args", argsToStringNoSelf toplevelfunc_args) ] +genTopLevelFuncCppHeader TopLevelVariable {..} = + let tmpl = "$returntype$ $funcname$ ( );" + in render tmpl [ ("returntype", rettypeToString toplevelvar_ret) + , ("funcname", "TopLevel_" + ++ maybe toplevelvar_name id toplevelvar_alias) + ] + +genTopLevelFuncCppDefinition :: TopLevelFunction -> String +genTopLevelFuncCppDefinition TopLevelFunction {..} = + let tmpl = "$returntype$ $funcname$ ( $args$ ) { \\\n $funcbody$\\\n}" + callstr = toplevelfunc_name ++ "(" + ++ argsToCallString toplevelfunc_args + ++ ")" + returnstr = case toplevelfunc_ret of + Void -> callstr ++ ";" + SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" + (CT _ctyp _isconst) -> "return "++callstr++";" + (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str + ++">(("++str++"*)"++callstr++");" + where str = class_name c' + (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" + funcDefStr = returnstr + in render tmpl [ ("returntype", rettypeToString toplevelfunc_ret) + , ("funcname", "TopLevel_" + ++ maybe toplevelfunc_name id toplevelfunc_alias) + , ("args", argsToStringNoSelf toplevelfunc_args) + , ("funcbody", funcDefStr ) + ] +genTopLevelFuncCppDefinition TopLevelVariable {..} = + let tmpl = "$returntype$ $funcname$ ( ) { \\\n $funcbody$\\\n}" + callstr = toplevelvar_name + returnstr = case toplevelvar_ret of + Void -> callstr ++ ";" + SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" + (CT _ctyp _isconst) -> "return "++callstr++";" + (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str + ++">(("++str++"*)"++callstr++");" + where str = class_name c' + (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" + funcDefStr = returnstr + in render tmpl [ ("returntype", rettypeToString toplevelvar_ret) + , ("funcname", "TopLevel_" + ++ maybe toplevelvar_name id toplevelvar_alias) + , ("funcbody", funcDefStr ) + ] diff --git a/lib/FFICXX/Generate/Code/Dependency.hs b/lib/FFICXX/Generate/Code/Dependency.hs --- a/lib/FFICXX/Generate/Code/Dependency.hs +++ b/lib/FFICXX/Generate/Code/Dependency.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Dependency @@ -13,6 +15,7 @@ module FFICXX.Generate.Code.Dependency where import Control.Applicative +import Data.Function (on) import Data.List import Data.Maybe import System.FilePath @@ -25,13 +28,11 @@ mkPkgHeaderFileName ::Class -> String mkPkgHeaderFileName c = (cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "h" - -- pkgname ++ (class_name c) ++ ".h" -- | mkPkgCppFileName ::Class -> String mkPkgCppFileName c = (cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "cpp" - -- pkgname ++ (class_name c) ++ ".cpp" -- | mkPkgIncludeHeadersInH :: Class -> [String] @@ -41,7 +42,6 @@ extheaders = nub . map ((++"Type.h") . cabal_pkgname . class_cabal) $ extclasses in map mkPkgHeaderFileName (class_allparents c) ++ extheaders - -- (map mkPkgHeaderFileName . class_allparents) c -- | @@ -49,11 +49,7 @@ mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . mkModuleDepCpp --- mkModuleDepFFI4One - --- mkModuleDepHigh -- class_allparents - - +-- | mkCIH :: (Class->([Namespace],[String])) -- ^ (mk namespace and include headers) -> Class -> ClassImportHeader @@ -64,7 +60,7 @@ (mkPkgIncludeHeadersInH c) (mkPkgIncludeHeadersInCPP c) ((snd . mkNSandIncHdrs) c) - in r -- trace (show r) r + in r -- | @@ -80,34 +76,36 @@ data Dep4Func = Dep4Func { returnDependency :: Maybe Class , argumentDependency :: [Class] } -{- --- | -data Dep4Interface = Dep4Interface - { parentDependency :: [Class] - , interfaceDependency :: [Class] - , typeDependecny :: [Class] - } --} -- | -extractClassDep :: Function -> Dep4Func {- ([Class],[Class]) -- ^ (rettypedep,argtypedep) -} -extractClassDep (Constructor args) = Dep4Func Nothing (catMaybes (map (extractClassFromType.fst) args)) -extractClassDep (Virtual ret _ args) = - Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args) -extractClassDep (NonVirtual ret _ args) = +extractClassDep :: Function -> Dep4Func +extractClassDep (Constructor args _) = Dep4Func Nothing (catMaybes (map (extractClassFromType.fst) args)) +extractClassDep (Virtual ret _ args _) = Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args) -extractClassDep (Static ret _ args) = +extractClassDep (NonVirtual ret _ args _) = Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args) -extractClassDep (AliasVirtual ret _ args _) = +extractClassDep (Static ret _ args _) = Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args) -extractClassDep Destructor = +{- extractClassDep (AliasVirtual ret _ args _) = + Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args) -} +extractClassDep (Destructor _) = Dep4Func Nothing [] +extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func +extractClassDepForTopLevelFunction f = + Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args) + where ret = case f of + TopLevelFunction {..} -> toplevelfunc_ret + TopLevelVariable {..} -> toplevelvar_ret + args = case f of + TopLevelFunction {..} -> toplevelfunc_args + TopLevelVariable {..} -> [] + -- | mkModuleDepRaw :: Class -> [Class] mkModuleDepRaw c = (nub . filter (/= c) . mapMaybe (returnDependency.extractClassDep) . class_funcs) c - -- ++ concatMap (snd.extractClassDep) fs + -- | mkModuleDepHighNonSource :: Class -> [Class] mkModuleDepHighNonSource c = @@ -151,10 +149,10 @@ in alldeps -mkClassModule :: (String,Class->([Namespace],[String])) +mkClassModule :: (Class->([Namespace],[String])) -> Class -> ClassModule -mkClassModule (pkgname,mkincheaders) c = +mkClassModule mkincheaders c = let r = (ClassModule <$> getClassModuleBase <*> pure <*> return . mkCIH mkincheaders @@ -163,7 +161,7 @@ <*> highs_source <*> ffis ) c - in r -- trace (show r) r + in r where highs_nonsource = map getClassModuleBase . mkModuleDepHighNonSource raws = map getClassModuleBase . mkModuleDepRaw @@ -171,14 +169,23 @@ ffis = map getClassModuleBase . mkModuleDepFFI -mkAllClassModulesAndCIH :: (String,Class->([Namespace],[String])) -- ^ (package name,mkIncludeHeaders) - -> [Class] - -> ([ClassModule],[ClassImportHeader]) -mkAllClassModulesAndCIH (pkgname,mkNSandIncHdrs) cs = - let ms = map (mkClassModule (pkgname,mkNSandIncHdrs)) cs +mkAll_ClassModules_CIH_TIH :: (String,Class->([Namespace],[String])) -- ^ (package name,mkIncludeHeaders) + -> ([Class],[TopLevelFunction]) + -> ([ClassModule],[ClassImportHeader],TopLevelImportHeader) +mkAll_ClassModules_CIH_TIH (pkgname,mkNSandIncHdrs) (cs,fs) = + let ms = map (mkClassModule mkNSandIncHdrs) cs cmpfunc x y = class_name (cihClass x) == class_name (cihClass y) cihs = nubBy cmpfunc (concatMap cmCIH ms) - in (ms,cihs) + -- for toplevel + tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs + tl_cs2 = mapMaybe (returnDependency . extractClassDepForTopLevelFunction) fs + tl_cs = nubBy ((==) `on` class_name) (tl_cs1 ++ tl_cs2) + tl_cihs = catMaybes $ + foldr (\c acc-> (find (\x -> (class_name . cihClass) x == class_name c) cihs):acc) [] tl_cs + -- + tih = TopLevelImportHeader (pkgname ++ "TopLevel") tl_cihs fs + in (ms,cihs,tih) + mkHSBOOTCandidateList :: [ClassModule] -> [String] mkHSBOOTCandidateList ms = nub (concatMap cmImportedModulesHighSource ms) diff --git a/lib/FFICXX/Generate/Code/HsFFI.hs b/lib/FFICXX/Generate/Code/HsFFI.hs --- a/lib/FFICXX/Generate/Code/HsFFI.hs +++ b/lib/FFICXX/Generate/Code/HsFFI.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFFI @@ -11,12 +13,13 @@ ----------------------------------------------------------------------------- module FFICXX.Generate.Code.HsFFI where - +import Data.Char (toLower) +import System.FilePath ((<.>)) +-- import FFICXX.Generate.Util --- import FFICXX.Generate.Type.Method import FFICXX.Generate.Type.Class --- import FFICXX.Generate.Generator.Templates + genHsFFI :: ClassImportHeader -> String genHsFFI header = let c = cihClass header @@ -24,17 +27,22 @@ allfns = concatMap (virtualFuncs . class_funcs) (class_allparents c) ++ (class_funcs c) - in intercalateWith connRet (hsFFIClassFunc h c) allfns + in intercalateWith connRet2 (hsFFIClassFunc h c) allfns genAllHsFFI :: [ClassImportHeader] -> String genAllHsFFI = intercalateWith connRet2 genHsFFI -------- +-- | this template will be deprecated ffistub :: String ffistub = "foreign import ccall \"$headerfilename$ $classname$_$funcname$\" $hsfuncname$ \n :: $hsargs$" +-- | this template will be used. +ffiTemplate :: String +ffiTemplate = "foreign import ccall \"$headerfilename$ $funcname$\" $hsfuncname$ \n :: $hsargs$" + hsFFIClassFunc :: FilePath -> Class -> Function -> String hsFFIClassFunc headerfilename c f = if isAbstractClass c then "" @@ -51,10 +59,51 @@ , ("funcname", aliasedFuncName c f) , ("hsfuncname",hscFuncName c f) , ("hsargs", hsFuncTyp c f) ] -{- | otherwise = render ffistub - [ ("headerfilename",headerFileName) - , ("classname",class_name c) - , ("funcname", aliasedFuncName c f) - , ("hsfuncname",hscFuncName c f) - , ("hsargs", hsFuncTyp c f) ] -} + +---------------------------- +-- for top level function -- +---------------------------- + +genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> String +genTopLevelFuncFFI header tfn = + case tfn of + TopLevelFunction {..} -> + let fname = maybe toplevelfunc_name id toplevelfunc_alias + (x:xs) = fname + headerfilename = tihHeaderFileName header <.> "h" + hfname = toLower x : xs + cfname = "c_" ++ toLowers hfname + args = toplevelfunc_args + ret = toplevelfunc_ret + argstr = concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret + in render ffiTemplate + [ ("headerfilename",headerfilename) + , ("funcname", "TopLevel_" ++ fname) + , ("hsfuncname",cfname) + , ("hsargs", argstr) ] + TopLevelVariable {..} -> + let fname = maybe toplevelvar_name id toplevelvar_alias + (x:xs) = fname + headerfilename = tihHeaderFileName header <.> "h" + hfname = toLower x : xs + cfname = "c_" ++ toLowers hfname + args = [] + ret = toplevelvar_ret + argstr = concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret + in render ffiTemplate + [ ("headerfilename",headerfilename) + , ("funcname", "TopLevel_" ++ fname) + , ("hsfuncname",cfname) + , ("hsargs", argstr) ] + + where hsargtype (CT ctype _) = hsCTypeName ctype + hsargtype (CPT x _) = hsCppTypeName x + hsargtype SelfType = "genTopLevelFuncFFI : no self for top level function " + hsargtype _ = error "undefined hsargtype" + + hsrettype Void = "IO ()" + hsrettype SelfType = "genTopLevelFuncFFI : no self for top level function " + hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype + hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x + diff --git a/lib/FFICXX/Generate/Code/HsFrontEnd.hs b/lib/FFICXX/Generate/Code/HsFrontEnd.hs --- a/lib/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/lib/FFICXX/Generate/Code/HsFrontEnd.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cpp @@ -14,6 +16,7 @@ import Control.Monad.State import Control.Monad.Reader +import Data.Char (toLower) import Data.List import qualified Data.Map as M import Data.Maybe @@ -47,25 +50,27 @@ ---------------- +-- | hsModuleDeclTmpl :: String hsModuleDeclTmpl = "module $moduleName$ $moduleExp$ where" +-- | genModuleDecl :: Module -> Reader AnnotateMap String genModuleDecl m = do - -- amap <- ask let modheader = render hsModuleDeclTmpl [ ("moduleName", module_name m) , ("moduleExp", mkModuleExports m) ] return (modheader) ---------------- - +-- | classprefix :: Class -> String classprefix c = let ps = (map typeclassName . class_parents) c in if null ps then "" else "(" ++ intercalate "," (map (++ " a") ps) ++ ") => " +-- | hsClassDeclHeaderTmpl :: String hsClassDeclHeaderTmpl = "$classann$\nclass $constraint$$classname$ a where" @@ -85,16 +90,16 @@ , ("funcann", mkComment 4 mann) ] prefixstr func = - let prefixlst = (snd . mkHsFuncArgType c . genericFuncArgs) func - ++ (snd . mkHsFuncRetType c ) func + let prefixlst = (snd . mkHsFuncArgType . genericFuncArgs) func + ++ (snd . mkHsFuncRetType . genericFuncRet ) func in if null prefixlst then "" else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => " argstr func = intercalateWith connArrow id $ [ "a" ] - ++ fst (mkHsFuncArgType c (genericFuncArgs func)) - ++ ["IO " ++ fst (mkHsFuncRetType c func)] + ++ fst (mkHsFuncArgType (genericFuncArgs func)) + ++ ["IO " ++ (fst . mkHsFuncRetType . genericFuncRet) func] bodylines = map bodyline . virtualFuncs $ (class_funcs c) return $ intercalateWith connRet id (header : bodylines) @@ -104,15 +109,13 @@ genAllHsFrontDecl :: [Class] -> Reader AnnotateMap String genAllHsFrontDecl = intercalateWithM connRet2 genHsFrontDecl --- fmap (intercalateWith connRet2) genHsFrontDecl - ------------------- genHsFrontInst :: Class -> Class -> String genHsFrontInst parent child | (not.isAbstractClass) child = - let headline = "instance " ++ typeclassName parent ++ " " ++ class_name child ++ " where" + let headline = "instance " ++ typeclassName parent ++ " " ++ (fst.hsClassName) child ++ " where" defline func = " " ++ hsFuncName child func ++ " = " ++ hsFuncXformer func ++ " " ++ hscFuncName child func deflines = (map defline) . virtualFuncs . class_funcs $ parent @@ -120,14 +123,6 @@ | otherwise = "" -{- -genAllHsFrontInst :: [Class] -> DaughterMap -> String -genAllHsFrontInst cs m = - let selflst = map (\x->(getClassModuleBase x,[x])) cs - lst = selflst ++ M.toList m - f (x,ys) = intercalateWith connRet2 (genHsFrontInst x) ys - in intercalateWith connRet2 f lst --} --------------------- @@ -135,10 +130,6 @@ hsClassInstExistCommonTmpl = "instance FPtr (Exist $highname$) where\n type Raw (Exist $highname$) = $rawname$\n get_fptr ($existConstructor$ obj) = castForeignPtr (get_fptr obj)\n cast_fptr_to_obj fptr = $existConstructor$ (cast_fptr_to_obj (fptr :: ForeignPtr $rawname$) :: $highname$)" -{- -- old -hsClassInstExistCommonTmpl :: String -hsClassInstExistCommonTmpl = "instance FPtr (Exist $highname$) where\n type Raw (Exist $highname$) = $rawname$\n get_fptr ($existConstructor$ obj) = castForeignPtr (get_fptr obj)\n cast_fptr_to_obj fptr = $existConstructor$ (cast_fptr_to_obj (fptr :: ForeignPtr $rawname$) :: $highname$)\n\ninstance Castable (Exist $highname$) (Ptr $rawname$) where\n cast = unsafeForeignPtrToPtr . get_fptr\n uncast = cast_fptr_to_obj . unsafePerformIO . newForeignPtr_" --} genHsFrontInstExistCommon :: Class -> String genHsFrontInstExistCommon c = render hsClassInstExistCommonTmpl tmplName where (highname,rawname) = hsClassName c @@ -170,15 +161,15 @@ where methodstr = intercalateWith connRet (genHsFrontInstExistVirtualMethod p c) (virtualFuncs.class_funcs $ p) tmplName = [ ("Iparent",typeclassName p) - , ("child",class_name c) + , ("child", (fst.hsClassName) c) , ("method", methodstr ) ] genHsFrontInstExistVirtualMethod :: Class -> Class -> Function -> String genHsFrontInstExistVirtualMethod p c f = case f of - Constructor _ -> error "error in genHsFrontInstExistVirtualMethod" - Destructor -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName + Constructor _ _ -> error "error in genHsFrontInstExistVirtualMethod" + Destructor _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName _ -> case func_ret f of SelfType -> render hsClassInstExistVirtualMethodSelfTmpl (tmplName++args) _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName @@ -203,15 +194,15 @@ then return Nothing else do let newfunc = head newfuncs - cann = maybe "" id $ M.lookup (PkgMethod, "new" ++ class_name c) amap + cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap newfuncann = mkComment 0 cann - newlinehead = "new" ++ class_name c ++ " :: " ++ argstr newfunc - newlinebody = "new" ++ class_name c ++ " = " + newlinehead = constructorName c ++ " :: " ++ argstr newfunc + newlinebody = constructorName c ++ " = " ++ hsFuncXformer newfunc ++ " " ++ hscFuncName c newfunc argstr func = intercalateWith connArrow id $ - map (ctypeToHsType c.fst) (genericFuncArgs func) - ++ ["IO " ++ (ctypeToHsType c.genericFuncRet) func] + map (ctypToHsTyp (Just c) . fst) (genericFuncArgs func) + ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) func] newline = newfuncann ++ "\n" ++ newlinehead ++ "\n" ++ newlinebody return (Just newline) where newfuncs = filter isNewFunc (class_funcs c) @@ -226,9 +217,9 @@ let header f = (aliasedFuncName c f) ++ " :: " ++ argstr f body f = (aliasedFuncName c f) ++ " = " ++ hsFuncXformer f ++ " " ++ hscFuncName c f argstr func = intercalateWith connArrow id $ - [class_name c] - ++ map (ctypeToHsType c.fst) (genericFuncArgs func) - ++ ["IO " ++ (ctypeToHsType c . genericFuncRet) func] + [(fst.hsClassName) c] + ++ map (ctypToHsTyp (Just c) . fst) (genericFuncArgs func) + ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) func] in Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) nonvirtualFuncs | otherwise = Nothing where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) @@ -244,16 +235,14 @@ let header f = (aliasedFuncName c f) ++ " :: " ++ argstr f body f = (aliasedFuncName c f) ++ " = " ++ hsFuncXformer f ++ " " ++ hscFuncName c f argstr f = intercalateWith connArrow id $ - map (ctypeToHsType c.fst) (genericFuncArgs f) - ++ ["IO " ++ (ctypeToHsType c . genericFuncRet) f] + map (ctypToHsTyp (Just c) . fst) (genericFuncArgs f) + ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) f] in Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) fs | otherwise = Nothing where fs = staticFuncs (class_funcs c) ----- - - genHsFrontInstCastable :: Class -> String genHsFrontInstCastable c | (not.isAbstractClass) c = @@ -313,45 +302,24 @@ , ("interfacename",iname) ] -{- -hsClassType :: Class -> String -hsClassType c = let decl = render rawToHighDecl tmplName - inst1 = render rawToHighInstance tmplName - exist1 = render existableInstance tmplName - in decl `connRet` inst1 `connRet` exist1 - where (highname,rawname) = hsClassName c - iname = typeclassName c - ename = existConstructorName c - tmplName = [ ("rawname",rawname) - , ("highname",highname) - , ("interfacename",iname) - , ("existConstructor",ename) - ] --} - -{- -mkRawTypes :: [Class] -> String -mkRawTypes = intercalateWith connRet2 hsClassRawType --} - hsClassDeclFuncTmpl :: String hsClassDeclFuncTmpl = "$funcann$\n $funcname$ :: $args$ " hsArgs :: Class -> Args -> String -hsArgs c = intercalateWith connArrow (ctypeToHsType c. fst) +hsArgs c = intercalateWith connArrow (ctypToHsTyp (Just c) . fst) -mkHsFuncArgType :: Class -> Args -> ([String],[String]) -mkHsFuncArgType c lst = +mkHsFuncArgType :: Args -> ([String],[String]) +mkHsFuncArgType lst = let (args,st) = runState (mapM mkFuncArgTypeWorker lst) ([],(0 :: Int)) in (args,fst st) where mkFuncArgTypeWorker (typ,_var) = case typ of SelfType -> return "a" - CT _ _ -> return $ ctypeToHsType c typ + CT _ _ -> return $ ctypToHsTyp Nothing typ CPT (CPTClass c') _ -> do (prefix,n) <- get - let cname = class_name c' + let cname = (fst.hsClassName) c' iname = typeclassNameFromStr cname newname = 'c' : show n newprefix1 = iname ++ " " ++ newname @@ -360,7 +328,7 @@ return newname CPT (CPTClassRef c') _ -> do (prefix,n) <- get - let cname = class_name c' + let cname = (fst.hsClassName) c' iname = typeclassNameFromStr cname newname = 'c' : show n newprefix1 = iname ++ " " ++ newname @@ -369,14 +337,13 @@ return newname _ -> error ("No such c type : " ++ show typ) -mkHsFuncRetType :: Class -> Function -> (String,[String]) -mkHsFuncRetType c func = - let rtyp = genericFuncRet func - in case rtyp of +mkHsFuncRetType :: Types -> (String,[String]) +mkHsFuncRetType rtyp = + case rtyp of SelfType -> ("a",[]) - CPT (CPTClass c') _ -> (cname,[]) where cname = class_name c' - CPT (CPTClassRef c') _ -> (cname,[]) where cname = class_name c' - _ -> (ctypeToHsType c rtyp,[]) + CPT (CPTClass c') _ -> (cname,[]) where cname = (fst.hsClassName) c' + CPT (CPTClassRef c') _ -> (cname,[]) where cname = (fst.hsClassName) c' + _ -> (ctypToHsTyp Nothing rtyp,[]) ---------- @@ -427,7 +394,6 @@ genHsFrontDowncastClass :: Class -> Reader AnnotateMap String genHsFrontDowncastClass c = do - -- amap <- ask let (highname,rawname) = hsClassName c downcaststr = render hsDowncastClassTmpl [ ("classname", highname) , ("ifacename", typeclassName c) @@ -452,11 +418,11 @@ then "" else "(..)" in if isAbstractClass c - then " " ++ ('I' : class_name c) ++ methodstr - else " " ++ class_name c ++ "(..)\n , " - ++ ('I' : class_name c) ++ methodstr - ++ "\n , upcast" ++ class_name c - ++ "\n , downcast" ++ class_name c + then " " ++ typeclassName c ++ methodstr + else " " ++ (fst.hsClassName) c ++ "(..)\n , " + ++ typeclassName c ++ methodstr + ++ "\n , upcast" ++ (fst.hsClassName) c + ++ "\n , downcast" ++ (fst.hsClassName) c ++ "\n" ++ genExportConstructorAndNonvirtual c ++ "\n" ++ genExportStatic c @@ -484,12 +450,6 @@ genExportList :: [Class] -> String genExportList = concatMap genExport --- let cs = filter (\x->class_name x == modname) all_classes --- in if null cs --- then error $ "no such class :" ++ modname --- else let c = head cs - - importOneClass :: String -> String -> String importOneClass mname typ = "import " ++ mname <.> typ @@ -500,7 +460,7 @@ genImportInModule :: [Class] -> String genImportInModule cs = let genImportOneClass c = - let n = getClassModuleBase c -- class_name c + let n = getClassModuleBase c in intercalateWith connRet (importOneClass n) $ ["RawType", "Interface", "Implementation"] in intercalate "\n" (map genImportOneClass cs) @@ -578,4 +538,43 @@ + +------------------------ +-- Top Level Function -- +------------------------ + +genTopLevelFuncDef :: TopLevelFunction -> String +genTopLevelFuncDef f@TopLevelFunction {..} = + let fname = hsFrontNameForTopLevelFunction f + cfname = "c_" ++ toLowers fname + args = toplevelfunc_args + ret = toplevelfunc_ret + xformerstr = let len = length args in if len > 0 then "xform" ++ show (len-1) else "xformnull" + prefixstr = + let prefixlst = (snd . mkHsFuncArgType) toplevelfunc_args + ++ (snd . mkHsFuncRetType) toplevelfunc_ret + in if null prefixlst + then "" + else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => " + + argstr = intercalateWith connArrow id $ + (fst . mkHsFuncArgType) toplevelfunc_args + ++ ["IO " ++ (fst . mkHsFuncRetType) toplevelfunc_ret] + defstr = fname ++ " = " ++ xformerstr ++ " " ++ cfname + in fname ++ " :: " ++ prefixstr ++ argstr ++ "\n" ++ defstr +genTopLevelFuncDef v@TopLevelVariable {..} = + let fname = hsFrontNameForTopLevelFunction v + cfname = "c_" ++ toLowers fname + args = [] + ret = toplevelvar_ret + xformerstr = let len = length args in if len > 0 then "xform" ++ show (len-1) else "xformnull" + prefixstr = + let prefixlst = (snd . mkHsFuncRetType) toplevelvar_ret + in if null prefixlst + then "" + else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => " + + argstr = intercalateWith connArrow id $ ["IO " ++ (fst . mkHsFuncRetType) toplevelvar_ret] + defstr = fname ++ " = " ++ xformerstr ++ " " ++ cfname + in fname ++ " :: " ++ prefixstr ++ argstr ++ "\n" ++ defstr diff --git a/lib/FFICXX/Generate/Code/MethodDef.hs b/lib/FFICXX/Generate/Code/MethodDef.hs --- a/lib/FFICXX/Generate/Code/MethodDef.hs +++ b/lib/FFICXX/Generate/Code/MethodDef.hs @@ -12,8 +12,6 @@ module FFICXX.Generate.Code.MethodDef where --- import FFICXX.Generate.Type.CType --- import FFICXX.Generate.Type.Method import FFICXX.Generate.Type.Class import FFICXX.Generate.Util @@ -62,7 +60,7 @@ (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str ++">(("++str++"*)"++callstr++");" where str = class_name c' - (CPT (CPTClassRef c') _) -> "return ((*)"++callstr++");" + (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | otherwise = let declstr = funcToDecl c func @@ -78,7 +76,7 @@ (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str ++">(("++str++"*)"++callstr++");" where str = class_name c' - (CPT (CPTClassRef c') _) -> "return ((*)"++callstr++");" + (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] diff --git a/lib/FFICXX/Generate/Generator/ContentMaker.hs b/lib/FFICXX/Generate/Generator/ContentMaker.hs --- a/lib/FFICXX/Generate/Generator/ContentMaker.hs +++ b/lib/FFICXX/Generate/Generator/ContentMaker.hs @@ -15,6 +15,7 @@ import Control.Applicative import Control.Lens (set,at) import Control.Monad.Trans.Reader +import Data.Function (on) import qualified Data.Map as M import Data.List import Data.List.Split (splitOn) @@ -37,6 +38,9 @@ csrcDir :: FilePath -> FilePath csrcDir installbasedir = installbasedir "csrc" +pkgModuleTemplate :: String +pkgModuleTemplate = "Pkg.hs" + moduleTemplate :: String moduleTemplate = "module.hs" @@ -176,7 +180,7 @@ `connRet2` genAllCppDefTmplNonVirtual classes -- dsmap = cgDaughterSelfMap cglobal - classDeclsStr = if class_name aclass /= "Deletable" + classDeclsStr = if (fst.hsClassName) aclass /= "Deletable" then mkParentDef genCppHeaderInstVirtual aclass `connRet2` genCppHeaderInstVirtual (aclass, aclass) @@ -216,11 +220,56 @@ templates [ ("header" , headerStr ) , ("namespace", namespaceStr ) - , ("cppbody", cppBody ) - , ("modname", class_name (cihClass header)) ] + , ("cppbody", cppBody ) + ] definitionTemplate + -- | +mkTopLevelFunctionHeader :: STGroup String + -> T.TypeMacro -- ^ typemacro prefix + -> String -- ^ C prefix + -> TopLevelImportHeader + -> String +mkTopLevelFunctionHeader templates (T.TypMcro typemacroprefix) cprefix tih = + let typemacrostr = typemacroprefix ++ "TOPLEVEL" ++ "__" + declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") + . map cihSelfHeader . tihClassDep $ tih + declBodyStr = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih) + in renderTemplateGroup + templates + [ ("typemacro", typemacrostr) + , ("cprefix", cprefix) + , ("declarationheader", declHeaderStr ) + , ("declarationbody", declBodyStr ) ] + declarationTemplate + + +-- | +mkTopLevelFunctionCppDef :: STGroup String + -> String -- ^ C prefix + -> TopLevelImportHeader + -> String +mkTopLevelFunctionCppDef templates cprefix tih = + let cihs = tihClassDep tih + declHeaderStr = "#include \"" ++ tihHeaderFileName tih <.> "h" ++ "\"" + `connRet2` + (intercalate "\n" (nub (map genAllCppHeaderInclude cihs))) + `connRet2` + ((intercalateWith connRet (\x->"#include \""++x++"\"") . map cihSelfHeader) cihs) + allns = nubBy ((==) `on` unNamespace) (tihClassDep tih >>= cihNamespace) + namespaceStr = do ns <- allns + ("using namespace " ++ unNamespace ns ++ ";\n") + declBodyStr = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih) + + in renderTemplateGroup + templates + [ ("header", declHeaderStr) + , ("namespace", namespaceStr) + , ("cppbody", declBodyStr ) ] + definitionTemplate + +-- | mkFFIHsc :: STGroup String -> ClassModule -> String @@ -324,16 +373,16 @@ -> String mkExistentialEach templates mother daughters = let makeOneDaughterGADTBody daughter = render hsExistentialGADTBodyTmpl - [ ( "mother", class_name mother ) - , ( "daughter", class_name daughter ) ] + [ ( "mother", (fst.hsClassName) mother ) + , ( "daughter",(fst.hsClassName) daughter ) ] makeOneDaughterCastBody daughter = render hsExistentialCastBodyTmpl - [ ( "mother", class_name mother ) - , ( "daughter", class_name daughter) ] + [ ( "mother", (fst.hsClassName) mother ) + , ( "daughter", (fst.hsClassName) daughter) ] gadtBody = intercalate "\n" (map makeOneDaughterGADTBody daughters) castBody = intercalate "\n" (map makeOneDaughterCastBody daughters) str = renderTemplateGroup templates - [ ( "mother" , class_name mother ) + [ ( "mother" , (fst.hsClassName) mother ) , ( "GADTbody" , gadtBody ) , ( "castbody" , castBody ) ] "ExistentialEach.hs" @@ -394,6 +443,40 @@ ] moduleTemplate in str + + +-- | +mkPkgHs :: String -> STGroup String -> [ClassModule] -> TopLevelImportHeader -> String +mkPkgHs modname templates mods tih = + let tfns = tihFuncs tih + exportListStr = intercalateWith (conn "\n, ") ((\x->"module " ++ x).cmModule) mods + ++ if null tfns + then "" + else "\n, " ++ intercalateWith (conn "\n, ") hsFrontNameForTopLevelFunction tfns + importListStr = intercalateWith connRet ((\x->"import " ++ x).cmModule) mods + ++ if null tfns + then "" + else "" `connRet2` "import Foreign.C" `connRet` "import Foreign.Ptr" + `connRet` "import FFICXX.Runtime.Cast" + `connRet` + intercalateWith connRet + ((\x->"import " ++ modname ++ "." ++ x ++ ".RawType") + .fst.hsClassName.cihClass) (tihClassDep tih) + topLevelDefStr = intercalateWith connRet2 (genTopLevelFuncFFI tih) tfns + `connRet2` + intercalateWith connRet2 genTopLevelFuncDef tfns + str = renderTemplateGroup + templates + [ ("summarymod", modname) + , ("exportList", exportListStr) + , ("importList", importListStr) + , ("topLevelDef", topLevelDefStr) + ] + pkgModuleTemplate + in str + + + -- | mkPackageInterface :: T.PackageInterface diff --git a/lib/FFICXX/Generate/Generator/Driver.hs b/lib/FFICXX/Generate/Generator/Driver.hs --- a/lib/FFICXX/Generate/Generator/Driver.hs +++ b/lib/FFICXX/Generate/Generator/Driver.hs @@ -13,7 +13,7 @@ module FFICXX.Generate.Generator.Driver where import Control.Applicative ((<$>)) -import Control.Monad (when) +import Control.Monad (when, forM_) import qualified Data.ByteString.Lazy.Char8 as L import Data.Digest.Pure.MD5 import System.Directory @@ -60,13 +60,41 @@ withFile fn WriteMode $ \h -> do hPutStrLn h (mkDeclHeader templates typemacroprefix cprefix header) +-- | +writeTopLevelFunctionHeaders :: STGroup String + -> FilePath + -> TypeMacro + -> String -- ^ c prefix + -> TopLevelImportHeader + -> IO () +writeTopLevelFunctionHeaders templates wdir typemacroprefix cprefix tih = do + let fn = wdir tihHeaderFileName tih <.> "h" + withFile fn WriteMode $ \h -> + hPutStrLn h (mkTopLevelFunctionHeader templates typemacroprefix cprefix tih) + + + + writeCppDef :: STGroup String -> FilePath -> ClassImportHeader -> IO () writeCppDef templates wdir header = do let fn = wdir cihSelfCpp header withFile fn WriteMode $ \h -> do hPutStrLn h (mkDefMain templates header) + -- | +writeTopLevelFunctionCppDef :: STGroup String + -> FilePath + -> TypeMacro + -> String -- ^ c prefix + -> TopLevelImportHeader + -> IO () +writeTopLevelFunctionCppDef templates wdir typemacroprefix cprefix tih = do + let fn = wdir tihHeaderFileName tih <.> "cpp" + withFile fn WriteMode $ \h -> hPutStrLn h (mkTopLevelFunctionCppDef templates cprefix tih) + + +-- | writeRawTypeHs :: STGroup String -> FilePath -> ClassModule -> IO () writeRawTypeHs templates wdir m = do let fn = wdir cmModule m <.> rawtypeHsFileName @@ -131,23 +159,17 @@ withFile fn WriteMode $ \h -> do hPutStrLn h (mkModuleHs templates m) +-- | writePkgHs :: String -- ^ summary module -> STGroup String -> FilePath -> [ClassModule] + -> TopLevelImportHeader -> IO () -writePkgHs modname templates wdir mods = do +writePkgHs modname templates wdir mods tih = do let fn = wdir modname <.> "hs" - exportListStr = intercalateWith (conn "\n, ") ((\x->"module " ++ x).cmModule) mods - importListStr = intercalateWith connRet ((\x->"import " ++ x).cmModule) mods - str = renderTemplateGroup - templates - [ ("summarymod", modname) - , ("exportList", exportListStr) - , ("importList", importListStr) ] - "Pkg.hs" - withFile fn WriteMode $ \h -> do - hPutStrLn h str + str = mkPkgHs modname templates mods tih + withFile fn WriteMode $ \h -> hPutStrLn h str notExistThenCreate :: FilePath -> IO () @@ -176,14 +198,21 @@ else copyFile src tgt -copyCppFiles :: FilePath -> FilePath -> String -> ClassImportHeader -> IO () -copyCppFiles wdir ddir cprefix header = do +copyCppFiles :: FilePath -> FilePath -> String -> (TopLevelImportHeader,[ClassImportHeader]) -> IO () +copyCppFiles wdir ddir cprefix (tih,cihs) = do let thfile = cprefix ++ "Type.h" - hfile = cihSelfHeader header - cppfile = cihSelfCpp header + tlhfile = tihHeaderFileName tih <.> "h" + tlcppfile = tihHeaderFileName tih <.> "cpp" copyFileWithMD5Check (wdir thfile) (ddir thfile) - copyFileWithMD5Check (wdir hfile) (ddir hfile) - copyFileWithMD5Check (wdir cppfile) (ddir cppfile) + doesFileExist (wdir tlhfile) + >>= flip when (copyFileWithMD5Check (wdir tlhfile) (ddir tlhfile)) + doesFileExist (wdir tlcppfile) + >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) + forM_ cihs $ \header-> do + let hfile = cihSelfHeader header + cppfile = cihSelfCpp header + copyFileWithMD5Check (wdir hfile) (ddir hfile) + copyFileWithMD5Check (wdir cppfile) (ddir cppfile) copyModule :: FilePath -> FilePath -> String -> ClassModule -> IO () copyModule wdir ddir summarymod m = do diff --git a/lib/FFICXX/Generate/Type/Class.hs b/lib/FFICXX/Generate/Type/Class.hs --- a/lib/FFICXX/Generate/Type/Class.hs +++ b/lib/FFICXX/Generate/Type/Class.hs @@ -1,4 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | @@ -21,19 +22,30 @@ import qualified Data.Map as M import System.FilePath -- --- import FFICXX.Generate.Type.CType import FFICXX.Generate.Util --- import FFICXX.Generate.Type.Method ---------- - -data CTypes = CTString | CTInt | CTDouble | CTBool | CTDoubleStar | CTVoidStar | CTIntStar | CTCharStarStar | CTUInt +-- | C types +data CTypes = CTString + | CTChar + | CTInt + | CTUInt + | CTLong + | CTULong + | CTDouble + | CTBool + | CTDoubleStar + | CTVoidStar + | CTIntStar + | CTCharStarStar + | CPointer CTypes deriving Show +-- | C++ types data CPPTypes = CPTClass Class | CPTClassRef Class deriving Show +-- | const flag data IsConst = Const | NoConst deriving Show @@ -49,15 +61,19 @@ ctypToStr :: CTypes -> IsConst -> String ctypToStr ctyp isconst = let typword = case ctyp of - CTString -> "char *" - CTInt -> "int " - CTUInt -> "unsigned int " + CTString -> "char*" + CTChar -> "char" + CTInt -> "int" + CTUInt -> "unsigned int" + CTLong -> "signed long" + CTULong -> "long unsigned int" CTDouble -> "double" CTBool -> "int" -- Currently available solution CTDoubleStar -> "double *" - CTVoidStar -> "void *" - CTIntStar -> "int *" - CTCharStarStar -> "char **" + CTVoidStar -> "void*" + CTIntStar -> "int*" + CTCharStarStar -> "char**" + CPointer s -> ctypToStr s NoConst ++ "*" in case isconst of Const -> "const" `connspace` typword NoConst -> typword @@ -78,6 +94,24 @@ uint_ :: Types uint_ = CT CTUInt NoConst +ulong_ :: Types +ulong_ = CT CTULong NoConst + +long_ :: Types +long_ = CT CTLong NoConst + +culong_ :: Types +culong_ = CT CTULong Const + +clong_ :: Types +clong_ = CT CTLong Const + +cchar_ :: Types +cchar_ = CT CTChar Const + +char_ :: Types +char_ = CT CTChar NoConst + short_ :: Types short_ = int_ @@ -108,6 +142,13 @@ charpp_ :: Types charpp_ = CT CTCharStarStar NoConst + +star_ :: CTypes -> Types +star_ t = CT (CPointer t) NoConst + +cstar_ :: CTypes -> Types +cstar_ t = CT (CPointer t) Const + self :: String -> (Types, String) self var = (self_, var) @@ -126,6 +167,24 @@ uint :: String -> (Types,String) uint var = (uint_ , var) +long :: String -> (Types,String) +long var = (long_, var) + +ulong :: String -> (Types,String) +ulong var = (ulong_ , var) + +clong :: String -> (Types,String) +clong var = (clong_, var) + +culong :: String -> (Types,String) +culong var = (culong_ , var) + +cchar :: String -> (Types,String) +cchar var = (cchar_ , var) + +char :: String -> (Types,String) +char var = (char_ , var) + short :: String -> (Types,String) short = int @@ -150,6 +209,13 @@ charpp :: String -> (Types, String) charpp var = (charpp_, var) +star :: CTypes -> String -> (Types, String) +star t var = (star_ t, var) + +cstar :: CTypes -> String -> (Types, String) +cstar t var = (cstar_ t, var) + + cppclass_ :: Class -> Types cppclass_ c = CPT (CPTClass c) NoConst @@ -168,62 +234,90 @@ hsCTypeName :: CTypes -> String hsCTypeName CTString = "CString" +hsCTypeName CTChar = "CChar" hsCTypeName CTInt = "CInt" -hsCTypeName CTUInt = "CUInt" +hsCTypeName CTUInt = "CUInt" +hsCTypeName CTLong = "CLong" +hsCTypeName CTULong = "CULong" hsCTypeName CTDouble = "CDouble" hsCTypeName CTDoubleStar = "(Ptr CDouble)" hsCTypeName CTBool = "CInt" hsCTypeName CTVoidStar = "(Ptr ())" hsCTypeName CTIntStar = "(Ptr CInt)" hsCTypeName CTCharStarStar = "(Ptr (CString))" - +hsCTypeName (CPointer t) = "(Ptr " ++ hsCTypeName t ++ ")" hsCppTypeName :: CPPTypes -> String -hsCppTypeName (CPTClass c) = "(Ptr Raw"++name++")" where name = class_name c -hsCppTypeName (CPTClassRef c) = "(Ptr Raw"++name++")" where name = class_name c +hsCppTypeName (CPTClass c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c) +hsCppTypeName (CPTClassRef c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c) ------------- type Args = [(Types,String)] -data Function = Constructor { func_args :: Args } +data Function = Constructor { func_args :: Args + , func_alias :: Maybe String + } | Virtual { func_ret :: Types , func_name :: String - , func_args :: Args } + , func_args :: Args + , func_alias :: Maybe String + } | NonVirtual { func_ret :: Types , func_name :: String - , func_args :: Args } + , func_args :: Args + , func_alias :: Maybe String + } | Static { func_ret :: Types , func_name :: String - , func_args :: Args } - | AliasVirtual { func_ret :: Types - , func_name :: String - , func_args :: Args - , func_alias :: String } - | Destructor + , func_args :: Args + , func_alias :: Maybe String + } + | Destructor { func_alias :: Maybe String } deriving Show --- | Protected { func_name :: String } +data TopLevelFunction = TopLevelFunction { toplevelfunc_ret :: Types + , toplevelfunc_name :: String + , toplevelfunc_args :: Args + , toplevelfunc_alias :: Maybe String + } + | TopLevelVariable { toplevelvar_ret :: Types + , toplevelvar_name :: String + , toplevelvar_alias :: Maybe String } + deriving Show +hsFrontNameForTopLevelFunction :: TopLevelFunction -> String +hsFrontNameForTopLevelFunction tfn = + let (x:xs) = case tfn of + TopLevelFunction {..} -> maybe toplevelfunc_name id toplevelfunc_alias + TopLevelVariable {..} -> maybe toplevelvar_name id toplevelvar_alias + in toLower x : xs + + +data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String + , tihClassDep :: [ClassImportHeader] + , tihFuncs :: [TopLevelFunction] + } + + isNewFunc :: Function -> Bool -isNewFunc (Constructor _ ) = True +isNewFunc (Constructor _ _) = True isNewFunc _ = False isDeleteFunc :: Function -> Bool -isDeleteFunc Destructor = True +isDeleteFunc (Destructor _) = True isDeleteFunc _ = False isVirtualFunc :: Function -> Bool -isVirtualFunc (Destructor) = True -isVirtualFunc (Virtual _ _ _) = True -isVirtualFunc (AliasVirtual _ _ _ _) = True +isVirtualFunc (Destructor _) = True +isVirtualFunc (Virtual _ _ _ _) = True isVirtualFunc _ = False isStaticFunc :: Function -> Bool -isStaticFunc (Static _ _ _) = True +isStaticFunc (Static _ _ _ _) = True isStaticFunc _ = False virtualFuncs :: [Function] -> [Function] @@ -295,14 +389,18 @@ , class_name :: String , class_parents :: [Class] , class_protected :: ProtectedMethod + , class_alias :: Maybe String , class_funcs :: [Function] } | AbstractClass { class_cabal :: Cabal , class_name :: String , class_parents :: [Class] , class_protected :: ProtectedMethod - , class_funcs :: [Function] } + , class_alias :: Maybe String + , class_funcs :: [Function] + } + newtype Namespace = NS { unNamespace :: String } deriving (Show) data ClassImportHeader = ClassImportHeader @@ -333,8 +431,8 @@ -- | Check abstract class isAbstractClass :: Class -> Bool -isAbstractClass (Class _ _ _ _ _) = False -isAbstractClass (AbstractClass _ _ _ _ _ ) = True +isAbstractClass (Class _ _ _ _ _ _) = False +isAbstractClass (AbstractClass _ _ _ _ _ _) = True instance Show Class where show x = show (class_name x) @@ -355,7 +453,7 @@ getClassModuleBase :: Class -> String -getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> class_name +getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName) @@ -379,37 +477,43 @@ f (Just cs) = Just (c:cs) in M.alter f p m - -ctypeToHsType :: Class -> Types -> String -ctypeToHsType _c Void = "()" -ctypeToHsType c SelfType = class_name c -ctypeToHsType _c (CT CTString _) = "String" -ctypeToHsType _c (CT CTInt _) = "Int" -ctypeToHsType _c (CT CTUInt _) = "Word" -ctypeToHsType _c (CT CTDouble _) = "Double" -ctypeToHsType _c (CT CTBool _ ) = "Int" -ctypeToHsType _c (CT CTDoubleStar _) = "[Double]" -ctypeToHsType _c (CT CTVoidStar _) = "(Ptr ())" -ctypeToHsType _c (CT CTIntStar _) = "[Int]" -ctypeToHsType _c (CT CTCharStarStar _) = "[String]" -ctypeToHsType _c (CPT (CPTClass c') _) = class_name c' -ctypeToHsType _c (CPT (CPTClassRef c') _) = class_name c' +-- | +ctypToHsTyp :: Maybe Class -> Types -> String +ctypToHsTyp _c Void = "()" +ctypToHsTyp (Just c) SelfType = (fst.hsClassName) c +ctypToHsTyp Nothing SelfType = error "ctypToHsTyp : SelfType but no class " +ctypToHsTyp _c (CT CTString _) = "CString" +ctypToHsTyp _c (CT CTInt _) = "CInt" +ctypToHsTyp _c (CT CTUInt _) = "CUInt" +ctypToHsTyp _c (CT CTChar _) = "CChar" +ctypToHsTyp _c (CT CTLong _) = "CLong" +ctypToHsTyp _c (CT CTULong _) = "CULong" +ctypToHsTyp _c (CT CTDouble _) = "CDouble" +ctypToHsTyp _c (CT CTBool _ ) = "CInt" +ctypToHsTyp _c (CT CTDoubleStar _) = "(Ptr CDouble)" +ctypToHsTyp _c (CT CTVoidStar _) = "(Ptr ())" +ctypToHsTyp _c (CT CTIntStar _) = "(Ptr CInt)" +ctypToHsTyp _c (CT CTCharStarStar _) = "(Ptr CString)" +ctypToHsTyp _c (CT (CPointer t) _) = hsCTypeName (CPointer t) +ctypToHsTyp _c (CPT (CPTClass c') _) = class_name c' +ctypToHsTyp _c (CPT (CPTClassRef c') _) = class_name c' typeclassName :: Class -> String -typeclassName c = 'I' : class_name c +typeclassName c = 'I' : fst (hsClassName c) typeclassNameFromStr :: String -> String typeclassNameFromStr = ('I':) hsClassName :: Class -> (String, String) -- ^ High-level, 'Raw'-level hsClassName c = - let cname = class_name c + let cname = maybe (class_name c) id (class_alias c) in (cname, "Raw" ++ cname) existConstructorName :: Class -> String -existConstructorName c = 'E' : class_name c +existConstructorName c = 'E' : (fst.hsClassName) c +-- | this is for FFI type. hsFuncTyp :: Class -> Function -> String hsFuncTyp c f = let args = genericFuncArgs f ret = genericFuncRet f @@ -427,7 +531,8 @@ hsrettype SelfType = "IO " ++ selfstr hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x - + +-- | this is for FFI hsFuncTypNoSelf :: Class -> Function -> String hsFuncTypNoSelf c f = let args = genericFuncArgs f ret = genericFuncRet f @@ -455,11 +560,11 @@ in (toLower x) : xs hsFuncXformer :: Function -> String -hsFuncXformer func@(Constructor _) = let len = length (genericFuncArgs func) - in if len > 0 - then "xform" ++ show (len - 1) - else "xformnull" -hsFuncXformer func@(Static _ _ _) = +hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func) + in if len > 0 + then "xform" ++ show (len - 1) + else "xformnull" +hsFuncXformer func@(Static _ _ _ _) = let len = length (genericFuncArgs func) in if len > 0 then "xform" ++ show (len - 1) @@ -471,44 +576,44 @@ genericFuncRet :: Function -> Types genericFuncRet f = case f of - Constructor _ -> self_ - Virtual t _ _ -> t - NonVirtual t _ _ -> t - Static t _ _ -> t - AliasVirtual t _ _ _ -> t - Destructor -> void_ + Constructor _ _ -> self_ + Virtual t _ _ _ -> t + NonVirtual t _ _ _-> t + Static t _ _ _ -> t + -- AliasVirtual t _ _ _ -> t + Destructor _ -> void_ genericFuncArgs :: Function -> Args -genericFuncArgs Destructor = [] +genericFuncArgs (Destructor _) = [] genericFuncArgs f = func_args f aliasedFuncName :: Class -> Function -> String aliasedFuncName c f = case f of - Constructor _ -> constructorName c - Virtual _ str _ -> str - NonVirtual _ str _ -> nonvirtualName c str - Static _ str _ -> nonvirtualName c str - AliasVirtual _ _ _ alias -> alias - Destructor -> destructorName + Constructor _ a -> maybe (constructorName c) id a + Virtual _ str _ a -> maybe str id a + NonVirtual _ str _ a-> maybe (nonvirtualName c str) id a + Static _ str _ a -> maybe (nonvirtualName c str) id a + -- AliasVirtual _ _ _ alias -> alias + Destructor a -> maybe destructorName id a cppStaticName :: Class -> Function -> String cppStaticName c f = class_name c ++ "::" ++ func_name f cppFuncName :: Class -> Function -> String cppFuncName c f = case f of - Constructor _ -> "new" - Virtual _ _ _ -> func_name f - NonVirtual _ _ _ -> func_name f - Static _ _ _ -> cppStaticName c f - AliasVirtual _ _ _ _ -> func_name f - Destructor -> destructorName + Constructor _ _ -> "new" + Virtual _ _ _ _ -> func_name f + NonVirtual _ _ _ _-> func_name f + Static _ _ _ _-> cppStaticName c f + -- AliasVirtual _ _ _ _ _ -> func_name f + Destructor _ -> destructorName constructorName :: Class -> String -constructorName c = "new" ++ (class_name c) +constructorName c = "new" ++ (fst.hsClassName) c nonvirtualName :: Class -> String -> String -nonvirtualName c str = firstLower (class_name c) ++ str +nonvirtualName c str = (firstLower.fst.hsClassName) c ++ str destructorName :: String destructorName = "delete" diff --git a/sample/cxxlib/include/A.h b/sample/cxxlib/include/A.h --- a/sample/cxxlib/include/A.h +++ b/sample/cxxlib/include/A.h @@ -7,6 +7,7 @@ A(); virtual void Foo( void ); + virtual void Foo2( long t ); }; #endif // __A__ diff --git a/sample/cxxlib/src/A.cpp b/sample/cxxlib/src/A.cpp --- a/sample/cxxlib/src/A.cpp +++ b/sample/cxxlib/src/A.cpp @@ -6,6 +6,11 @@ void A::Foo() { -std::cout << "A:foo" << std::endl; + std::cout << "A:Foo" << std::endl; } +void A::Foo2( signed long t ) +{ + std::cout << "A:Foo2 : got " << t << std::endl; +} + diff --git a/sample/mysample-generator/MySampleGen.hs b/sample/mysample-generator/MySampleGen.hs --- a/sample/mysample-generator/MySampleGen.hs +++ b/sample/mysample-generator/MySampleGen.hs @@ -30,20 +30,23 @@ myclass = Class mycabal a :: Class -a = myclass "A" [] mempty - [ Constructor [] - , Virtual void_ "Foo" [ ] +a = myclass "A" [] mempty Nothing + [ Constructor [] Nothing + , Virtual void_ "Foo" [ ] Nothing + , Virtual void_ "Foo2" [ long "t" ] Nothing ] b :: Class -b = myclass "B" [a] mempty - [ Constructor [] - , Virtual void_ "Bar" [] +b = myclass "B" [a] mempty Nothing + [ Constructor [] Nothing + , Virtual void_ "Bar" [] Nothing ] myclasses = [ a, b] +toplevelfunctions = [ ] + -- | cabalTemplate :: String cabalTemplate = "Pkg.cabal" @@ -52,10 +55,10 @@ -- | mkCabalFile :: FFICXXConfig -> STGroup String - -> [ClassModule] + -> (TopLevelImportHeader,[ClassModule]) -> FilePath -> IO () -mkCabalFile config templates classmodules cabalfile = do +mkCabalFile config templates (tih,classmodules) cabalfile = do cpath <- getCurrentDirectory let str = renderTemplateGroup @@ -65,9 +68,9 @@ , ("license", "" ) , ("buildtype", "Simple") , ("deps", "" ) - , ("csrcFiles", genCsrcFiles classmodules) + , ("csrcFiles", genCsrcFiles (tih,classmodules)) , ("includeFiles", genIncludeFiles "MySample" classmodules) - , ("cppFiles", genCppFiles classmodules) + , ("cppFiles", genCppFiles (tih,classmodules)) , ("exposedModules", genExposedModules "MySample" classmodules) , ("otherModules", genOtherModules classmodules) , ("extralibdirs", cpath ".." "cxxlib" "lib" ) -- this need to be changed @@ -93,7 +96,7 @@ workingDir = fficxxconfig_workingDir cfg installDir = fficxxconfig_installBaseDir cfg pkgname = "MySample" - (mods,cihs) = mkAllClassModulesAndCIH ("MySample", (\c->([],[class_name c ++ ".h"]))) myclasses + (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH ("MySample", (\c->([],[class_name c ++ ".h"]))) (myclasses,toplevelfunctions) hsbootlst = mkHSBOOTCandidateList mods cglobal = mkGlobal myclasses summarymodule = "MySample" @@ -107,7 +110,7 @@ notExistThenCreate (installDir "csrc") -- putStrLn "cabal file generation" - mkCabalFile cfg templates mods (workingDir cabalFileName) + mkCabalFile cfg templates (tih,mods) (workingDir cabalFileName) -- putStrLn "header file generation" writeTypeDeclHeaders templates workingDir (TypMcro "__MYSAMPLE__") pkgname cihs @@ -138,12 +141,12 @@ mapM_ (writeModuleHs templates workingDir) mods -- putStrLn "summary module generation generation" - writePkgHs summarymodule templates workingDir mods + writePkgHs summarymodule templates workingDir mods tih -- putStrLn "copying" copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) -- copyPredefined templateDir (srcDir ibase) pkgname - mapM_ (copyCppFiles workingDir (csrcDir installDir) pkgname) cihs + copyCppFiles workingDir (csrcDir installDir) pkgname (tih,cihs) mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods diff --git a/sample/mysample-generator/use_mysample.hs b/sample/mysample-generator/use_mysample.hs --- a/sample/mysample-generator/use_mysample.hs +++ b/sample/mysample-generator/use_mysample.hs @@ -11,5 +11,6 @@ foo (upcastA b) bar b - + + foo2 a 3 diff --git a/sample/snappy-generator/SnappyGen.hs b/sample/snappy-generator/SnappyGen.hs new file mode 100644 --- /dev/null +++ b/sample/snappy-generator/SnappyGen.hs @@ -0,0 +1,72 @@ +import Data.Monoid (mempty) +-- +import FFICXX.Generate.Builder +import FFICXX.Generate.Type.Class + +snappyclasses = [ ] + +mycabal = Cabal { cabal_pkgname = "Snappy" + , cabal_cheaderprefix = "Snappy" + , cabal_moduleprefix = "Snappy" } + +-- myclass = Class mycabal + +-- this is standard string library +string :: Class +string = + Class mycabal "string" [] mempty (Just "CppString") + [ + ] + + +source :: Class +source = + Class mycabal "Source" [] mempty Nothing + [ Virtual ulong_ "Available" [] Nothing + , Virtual (cstar_ CTChar) "Peek" [ star CTULong "len" ] Nothing + , Virtual void_ "Skip" [ ulong "n" ] Nothing + ] + + +sink :: Class +sink = + Class mycabal "Sink" [] mempty Nothing + [ Virtual void_ "Append" [ cstar CTChar "bytes", ulong "n" ] Nothing + , Virtual (cstar_ CTChar) "GetAppendBuffer" [ ulong "len", star CTChar "scratch" ] Nothing + ] + +byteArraySource :: Class +byteArraySource = + Class mycabal "ByteArraySource" [source] mempty Nothing + [ Constructor [ cstar CTChar "p", ulong "n" ] Nothing + ] + + +uncheckedByteArraySink :: Class +uncheckedByteArraySink = + Class mycabal "UncheckedByteArraySink" [sink] mempty Nothing + [ Constructor [ star CTChar "dest" ] Nothing + , NonVirtual (star_ CTChar) "CurrentDestination" [] Nothing + ] + + +myclasses = [ source, sink, byteArraySource, uncheckedByteArraySink, string ] + +toplevelfunctions = + [ TopLevelFunction ulong_ "Compress" [cppclass source "src", cppclass sink "snk"] Nothing + , TopLevelFunction bool_ "GetUncompressedLength" [cppclass source "src", star CTUInt "result"] Nothing + , TopLevelFunction ulong_ "Compress" [cstar CTChar "input", ulong "input_length", cppclass string "output"] (Just "compress_1") + , TopLevelFunction bool_ "Uncompress" [cstar CTChar "compressed", ulong "compressed_length", cppclass string "uncompressed"] Nothing + , TopLevelFunction void_ "RawCompress" [cstar CTChar "input", ulong "input_length", star CTChar "compresseed", star CTULong "compressed_length" ] Nothing + , TopLevelFunction bool_ "RawUncompress" [cstar CTChar "compressed", ulong "compressed_length", star CTChar "uncompressed"] Nothing + , TopLevelFunction bool_ "RawUncompress" [cppclass source "src", star CTChar "uncompressed"] (Just "rawUncompress_1") + , TopLevelFunction ulong_ "MaxCompressedLength" [ ulong "source_bytes" ] Nothing + , TopLevelFunction bool_ "GetUncompressedLength" [ cstar CTChar "compressed", ulong "compressed_length", star CTULong "result" ] (Just "getUncompressedLength_1") + , TopLevelFunction bool_ "IsValidCompressedBuffer" [ cstar CTChar "compressed", ulong "compressed_length" ] Nothing + ] + +main :: IO () +main = do + simpleBuilder (mycabal,myclasses,toplevelfunctions) + + diff --git a/template/Implementation.hs.st b/template/Implementation.hs.st --- a/template/Implementation.hs.st +++ b/template/Implementation.hs.st @@ -9,6 +9,8 @@ $implImport$ import Data.Word +import Foreign.C +import Foreign.Ptr import Foreign.ForeignPtr import System.IO.Unsafe diff --git a/template/Interface.hs.st b/template/Interface.hs.st --- a/template/Interface.hs.st +++ b/template/Interface.hs.st @@ -7,6 +7,8 @@ $ifaceHeader$ import Data.Word +import Foreign.C +import Foreign.Ptr import Foreign.ForeignPtr import FFICXX.Runtime.Cast diff --git a/template/Pkg.cabal.st b/template/Pkg.cabal.st --- a/template/Pkg.cabal.st +++ b/template/Pkg.cabal.st @@ -3,11 +3,12 @@ Synopsis: $synopsis$ Description: $description$ Homepage: $homepage$ -$license$ +License: $license$ +License-file: $licensefile$ Author: $author$ Maintainer: $maintainer$ Category: $category$ -Tested-with: GHC >= 7.0 +Tested-with: GHC >= 7.6 Build-Type: $buildtype$ cabal-version: >=1.10 Extra-source-files: diff --git a/template/Pkg.cpp.st b/template/Pkg.cpp.st --- a/template/Pkg.cpp.st +++ b/template/Pkg.cpp.st @@ -35,8 +35,4 @@ $cppbody$ -void dummy$modname$ ( void ) -{ - -} diff --git a/template/Pkg.hs.st b/template/Pkg.hs.st --- a/template/Pkg.hs.st +++ b/template/Pkg.hs.st @@ -4,3 +4,4 @@ $importList$ +$topLevelDef$ diff --git a/template/PkgType.h.st b/template/PkgType.h.st --- a/template/PkgType.h.st +++ b/template/PkgType.h.st @@ -5,12 +5,6 @@ #ifndef $typemacro$ #define $typemacro$ -#undef ROOT_TYPE_DECLARATION -#define ROOT_TYPE_DECLARATION(Type) \\ -typedef struct Type ##_tag Type ## _t; \\ -typedef Type ## _t * Type ## _p; \\ -typedef Type ## _t const* const_ ## Type ## _p - $typeDeclBody$ #endif // $typemacro$ diff --git a/template/module.hs.st b/template/module.hs.st --- a/template/module.hs.st +++ b/template/module.hs.st @@ -5,3 +5,4 @@ $importList$ +