fficxx 0.1.0 → 0.2

raw patch · 22 files changed

+856/−289 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• fficxx.cabal +3/−1
• lib/FFICXX/Generate/Builder.hs +149/−0
• lib/FFICXX/Generate/Code/Cpp.hs +89/−22
• lib/FFICXX/Generate/Code/Dependency.hs +42/−35
• lib/FFICXX/Generate/Code/HsFFI.hs +59/−10
• lib/FFICXX/Generate/Code/HsFrontEnd.hs +82/−83
• lib/FFICXX/Generate/Code/MethodDef.hs +2/−4
• lib/FFICXX/Generate/Generator/ContentMaker.hs +91/−8
• lib/FFICXX/Generate/Generator/Driver.hs +47/−18
• lib/FFICXX/Generate/Type/Class.hs +185/−80
• sample/cxxlib/include/A.h +1/−0
• sample/cxxlib/src/A.cpp +6/−1
• sample/mysample-generator/MySampleGen.hs +17/−14
• sample/mysample-generator/use_mysample.hs +2/−1
• sample/snappy-generator/SnappyGen.hs +72/−0
• template/Implementation.hs.st +2/−0
• template/Interface.hs.st +2/−0
• template/Pkg.cabal.st +3/−2
• template/Pkg.cpp.st +0/−4
• template/Pkg.hs.st +1/−0
• template/PkgType.h.st +0/−6
• template/module.hs.st +1/−0

@@ -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

@@ -0,0 +1,149 @@+{-# LANGUAGE ScopedTypeVariables #-}++-----------------------------------------------------------------------------+-- |+-- Module      : FFICXX.Generate.Builder +-- Copyright   : (c) 2011-2013 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- 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 +++

@@ -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 ## _t, Type>((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 ## _t, Type>((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 )+                    ]   

@@ -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)

@@ -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 + 

@@ -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  

@@ -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, "}"]   

@@ -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 

@@ -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 

@@ -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" 

@@ -7,6 +7,7 @@   A();    virtual void Foo( void ); +  virtual void Foo2( long t ); };   #endif // __A__

@@ -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; +}+ 

@@ -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   

@@ -11,5 +11,6 @@   foo (upcastA b)     bar b -+  +  foo2 a 3 

@@ -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)++

@@ -9,6 +9,8 @@ $implImport$  import Data.Word+import Foreign.C+import Foreign.Ptr  import Foreign.ForeignPtr  import System.IO.Unsafe

@@ -7,6 +7,8 @@ $ifaceHeader$  import Data.Word+import Foreign.C+import Foreign.Ptr import Foreign.ForeignPtr import FFICXX.Runtime.Cast 

@@ -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: 

@@ -35,8 +35,4 @@  $cppbody$ -void dummy$modname$ ( void ) -{-  -} 

@@ -4,3 +4,4 @@  $importList$ +$topLevelDef$

@@ -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$

@@ -5,3 +5,4 @@  $importList$ +