fficxx (empty) → 0.1
raw patch · 38 files changed
+2895/−0 lines, 38 filesdep +Cabaldep +HStringTemplatedep +basesetup-changed
Dependencies added: Cabal, HStringTemplate, base, bytestring, containers, directory, either, errors, filepath, hashable, lens, mtl, process, pureMD5, split, template-haskell, transformers, unordered-containers
Files
- LICENSE +25/−0
- Setup.lhs +10/−0
- fficxx.cabal +65/−0
- lib/FFICXX/Generate/Code/Cabal.hs +44/−0
- lib/FFICXX/Generate/Code/Cpp.hs +195/−0
- lib/FFICXX/Generate/Code/Dependency.hs +184/−0
- lib/FFICXX/Generate/Code/HsFFI.hs +60/−0
- lib/FFICXX/Generate/Code/HsFrontEnd.hs +581/−0
- lib/FFICXX/Generate/Code/MethodDef.hs +93/−0
- lib/FFICXX/Generate/Config.hs +21/−0
- lib/FFICXX/Generate/Generator/ContentMaker.hs +408/−0
- lib/FFICXX/Generate/Generator/Driver.hs +210/−0
- lib/FFICXX/Generate/QQ/Verbatim.hs +23/−0
- lib/FFICXX/Generate/Type/Annotate.hs +23/−0
- lib/FFICXX/Generate/Type/Class.hs +514/−0
- lib/FFICXX/Generate/Type/Module.hs +22/−0
- lib/FFICXX/Generate/Type/PackageInterface.hs +27/−0
- lib/FFICXX/Generate/Util.hs +113/−0
- lib/FFICXX/Paths_fficxx.hs +6/−0
- template/Cast.hs.st +14/−0
- template/Class.hs-boot.st +3/−0
- template/Existential.hs.st +28/−0
- template/ExistentialEach.hs.st +19/−0
- template/FFI.hsc.st +19/−0
- template/Implementation.hs.st +17/−0
- template/Interface.hs.st +15/−0
- template/Module.h.st +18/−0
- template/Pkg.cabal.st +40/−0
- template/Pkg.cpp.st +42/−0
- template/Pkg.hs.st +6/−0
- template/PkgType.h.st +20/−0
- template/RawType.hs.st +10/−0
- template/classdef.cpp.st +3/−0
- template/declbody.h.st +4/−0
- template/funcdecl.h.st +1/−0
- template/function.cpp.st +4/−0
- template/functionbody.cpp.st +1/−0
- template/module.hs.st +7/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2011-2013, Ian-Woo Kim. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.lhs view
@@ -0,0 +1,10 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> import Distribution.PackageDescription+> --import System.Process+> main = defaultMain+> --main = defaultMainWithHooks testUserHooks+> --testUserHooks = simpleUserHooks { +> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo+> -- }
+ fficxx.cabal view
@@ -0,0 +1,65 @@+Name: fficxx+Version: 0.1+Synopsis: automatic C++ binding generation+Description: automatic C++ binding generation +License: BSD3+License-file: LICENSE+Author: Ian-Woo Kim+Maintainer: Ian-Woo Kim <ianwookim@gmail.com>+Build-Type: Simple+Category: FFI Tools+Cabal-Version: >= 1.8+Data-files: template/*.h.st+ template/*.hs.st+ template/*.hsc.st+ template/*.hs-boot.st+ template/*.cpp.st+ template/Pkg.cabal.st++Source-repository head+ type: git+ location: http://www.github.com/wavewave/fficxx++Library+ hs-source-dirs: lib+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind+ ghc-prof-options: -caf-all -auto-all+ Build-Depends: base == 4.* , + mtl>2, + containers, + filepath>1, + directory, + HStringTemplate, + split,+ process,+ transformers >= 0.3, + template-haskell, + hashable,+ unordered-containers,+ lens > 3,+ either, + errors,+ bytestring,+ pureMD5, + Cabal++ Exposed-Modules: + FFICXX.Generate.Type.Class+ FFICXX.Generate.Type.Module+ FFICXX.Generate.Type.PackageInterface+ FFICXX.Generate.Config+ FFICXX.Generate.Code.MethodDef+ FFICXX.Generate.Code.Cpp+ FFICXX.Generate.Code.HsFrontEnd+ FFICXX.Generate.Code.HsFFI+ FFICXX.Generate.Code.Cabal+ FFICXX.Generate.Code.Dependency+ FFICXX.Generate.Generator.Driver+ FFICXX.Generate.Generator.ContentMaker+ FFICXX.Generate.Util+ FFICXX.Generate.QQ.Verbatim+ FFICXX.Generate.Type.Annotate+ FFICXX.Paths_fficxx+ Other-Modules:+ Paths_fficxx+
+ lib/FFICXX/Generate/Code/Cabal.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Code.Cabal+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Code.Cabal where++import FFICXX.Generate.Type.Class ++cabalIndentation :: String +cabalIndentation = replicate 23 ' ' +++-- | generate exposed module list in cabal file +genExposedModules :: String -> [ClassModule] -> String+genExposedModules summarymod cmods = + let indentspace = cabalIndentation+ summarystrs = indentspace ++ summarymod + cmodstrs = map ((\x->indentspace++x).cmModule) cmods + rawType = map ((\x->indentspace++x++".RawType").cmModule) cmods+ ffi = map ((\x->indentspace++x++".FFI").cmModule) cmods+ interface= map ((\x->indentspace++x++".Interface").cmModule) cmods+ cast = map ((\x->indentspace++x++".Cast").cmModule) cmods + implementation = map ((\x->indentspace++x++".Implementation").cmModule) cmods+ in unlines ([summarystrs]++cmodstrs++rawType++ffi++interface++cast++implementation)++-- | generate other modules in cabal file +genOtherModules :: [ClassModule] -> String +genOtherModules _cmods = "" +{- let indentspace = cabalIndentation + rawType = map ((\x->indentspace++x++".RawType").cmModule) cmods+ ffi = map ((\x->indentspace++x++".FFI").cmModule) cmods+ interface= map ((\x->indentspace++x++".Interface").cmModule) cmods+ cast = map ((\x->indentspace++x++".Cast").cmModule) cmods + implementation = map ((\x->indentspace++x++".Implementation").cmModule) cmods+ in unlines (rawType++ffi++interface++cast++implementation)+-}
+ lib/FFICXX/Generate/Code/Cpp.hs view
@@ -0,0 +1,195 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Code.Cpp+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------+++module FFICXX.Generate.Code.Cpp where++import Data.Char +import Data.List+import System.FilePath++import FFICXX.Generate.Util+-- import FFICXX.Generate.Type.Method+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Code.MethodDef+import FFICXX.Generate.Code.Cabal++-- Class Declaration and Definition++----+---- Declaration+----++---- "Class Type Declaration" Instances++genCppHeaderTmplType :: Class -> String +genCppHeaderTmplType c = let tmpl = "ROOT_TYPE_DECLARATION($classname$);" + in render tmpl [ ("classname", class_name c) ] ++genAllCppHeaderTmplType :: [Class] -> String+genAllCppHeaderTmplType = intercalateWith connRet (genCppHeaderTmplType) ++---- "Class Declaration Virtual" Declaration ++genCppHeaderTmplVirtual :: Class -> String +genCppHeaderTmplVirtual aclass = + let tmpl = "#undef ROOT_$classname$_DECLARATIONVIRT\\\n#define ROOT_$classname$_DECLARATIONVIRT(Type) \\\\\\\n$funcdecl$" + declBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) + , ("funcdecl" , funcDeclStr ) ] + funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass+ in declBodyStr + +genAllCppHeaderTmplVirtual :: [Class] -> String +genAllCppHeaderTmplVirtual = intercalateWith connRet2 genCppHeaderTmplVirtual++---- "Class Declaration Non-Virtual" Declaration++genCppHeaderTmplNonVirtual :: Class -> String+genCppHeaderTmplNonVirtual c = + let tmpl = "#undef ROOT_$classname$_DECLARATIONNONVIRT\\\n#define ROOT_$classname$_DECLARATIONNONVIRT(Type) \\\\\\\n$funcdecl$" + declBodyStr = render tmpl [ ("classname", map toUpper (class_name c) ) + , ("funcdecl" , funcDeclStr ) ] + funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc) + . class_funcs $ c+ in declBodyStr ++genAllCppHeaderTmplNonVirtual :: [Class] -> String +genAllCppHeaderTmplNonVirtual = intercalateWith connRet genCppHeaderTmplNonVirtual++---- "Class Declaration Virtual/NonVirtual" Instances++genCppHeaderInstVirtual :: (Class,Class) -> String +genCppHeaderInstVirtual (p,c) = + let strc = map toUpper (class_name p) + in "ROOT_"++strc++"_DECLARATIONVIRT(" ++ class_name c ++ ");\n"++genCppHeaderInstNonVirtual :: Class -> String +genCppHeaderInstNonVirtual c = + let strx = map toUpper (class_name c) + in "ROOT_"++strx++"_DECLARATIONNONVIRT(" ++ class_name c ++ ");\n" ++genAllCppHeaderInstNonVirtual :: [Class] -> String +genAllCppHeaderInstNonVirtual = + intercalateWith connRet genCppHeaderInstNonVirtual+++----+---- Definition+----++---- "Class Definition Virtual" Declaration++genCppDefTmplVirtual :: Class -> String +genCppDefTmplVirtual aclass = + let tmpl = "#undef ROOT_$classname$_DEFINITIONVIRT\\\n#define ROOT_$classname$_DEFINITIONVIRT(Type)\\\\\\\n$funcdef$" + defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) + , ("funcdef" , funcDefStr ) ] + funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass+ in defBodyStr + +genAllCppDefTmplVirtual :: [Class] -> String+genAllCppDefTmplVirtual = intercalateWith connRet2 genCppDefTmplVirtual++---- "Class Definition NonVirtual" Declaration++genCppDefTmplNonVirtual :: Class -> String +genCppDefTmplNonVirtual aclass = + let tmpl = "#undef ROOT_$classname$_DEFINITIONNONVIRT\\\n#define ROOT_$classname$_DEFINITIONNONVIRT(Type)\\\\\\\n$funcdef$" + defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) + , ("funcdef" , funcDefStr ) ] + funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc) + . class_funcs $ aclass+ in defBodyStr + +genAllCppDefTmplNonVirtual :: [Class] -> String+genAllCppDefTmplNonVirtual = intercalateWith connRet2 genCppDefTmplNonVirtual++---- "Class Definition Virtual/NonVirtual" Instances++genCppDefInstVirtual :: (Class,Class) -> String +genCppDefInstVirtual (p,c) = + let strc = map toUpper (class_name p) + in "ROOT_"++strc++"_DEFINITIONVIRT(" ++ class_name c ++ ")\n"++genCppDefInstNonVirtual :: Class -> String+genCppDefInstNonVirtual c = + let tmpl = "ROOT_$capitalclassname$_DEFINITIONNONVIRT($classname$)" + in render tmpl [ ("capitalclassname", toUppers (class_name c))+ , ("classname", class_name c) ] ++genAllCppDefInstNonVirtual :: [Class] -> String +genAllCppDefInstNonVirtual = + intercalateWith connRet genCppDefInstNonVirtual++-----+++-----------------++genAllCppHeaderInclude :: ClassImportHeader -> String +genAllCppHeaderInclude header = + intercalateWith connRet (\x->"#include \""++x++"\"") $+ cihIncludedHPkgHeadersInCPP header+ ++ cihIncludedCPkgHeaders header++genModuleIncludeHeader :: [ClassImportHeader] -> String +genModuleIncludeHeader headers =+ let strlst = map ((\x->"#include \""++x++"\"") . cihSelfHeader) headers + in intercalate "\n" strlst ++-----++ +----++genIncludeFiles :: String -- ^ package name + -> [ClassModule] + -> String+genIncludeFiles pkgname cmods =+ let indent = cabalIndentation + selfheaders' = do + x <- cmods+ y <- cmCIH x+ return (cihSelfHeader y) + selfheaders = nub selfheaders'+ includeFileStrs = map (\x->indent++x) selfheaders+ in unlines ((indent++pkgname++"Type.h") : includeFileStrs)++genCsrcFiles :: [ClassModule] -> String+genCsrcFiles cmods =+ let indent = cabalIndentation + selfheaders' = do + x <- cmods+ y <- cmCIH x+ return (cihSelfHeader y) + selfheaders = nub selfheaders'+ selfcpp' = do + x <- cmods+ y <- cmCIH x + return (cihSelfCpp y)+ selfcpp = nub selfcpp' + includeFileStrsWithCsrc = map (\x->indent++"csrc"</>x) selfheaders+ cppFilesWithCsrc = map (\x->indent++"csrc"</>x) selfcpp+ in unlines (includeFileStrsWithCsrc ++ cppFilesWithCsrc)++genCppFiles :: [ClassModule] -> String +genCppFiles cmods = + let indent = cabalIndentation + selfcpp' = do + x <- cmods+ y <- cmCIH x+ return (cihSelfCpp y) + selfcpp = nub selfcpp'+ cppFileStrs = map (\x->indent++ "csrc" </> x) selfcpp+ in unlines cppFileStrs ++
+ lib/FFICXX/Generate/Code/Dependency.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Code.Dependency+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Code.Dependency where++import Control.Applicative+import Data.List +import Data.Maybe+import System.FilePath +--+import FFICXX.Generate.Type.Class +--+-- import Debug.Trace ++-- | +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] +mkPkgIncludeHeadersInH c =+ let pkgname = (cabal_pkgname . class_cabal) c+ extclasses = (filter ((/= pkgname) . cabal_pkgname . class_cabal) . mkModuleDepCpp) c+ extheaders = nub . map ((++"Type.h") . cabal_pkgname . class_cabal) $ extclasses + in map mkPkgHeaderFileName (class_allparents c) ++ extheaders++ -- (map mkPkgHeaderFileName . class_allparents) c + ++-- | +mkPkgIncludeHeadersInCPP :: Class -> [String] +mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . mkModuleDepCpp +++-- mkModuleDepFFI4One++-- mkModuleDepHigh -- class_allparents +++mkCIH :: (Class->([Namespace],[String])) -- ^ (mk namespace and include headers) + -> Class + -> ClassImportHeader+mkCIH mkNSandIncHdrs c = let r = ClassImportHeader c + (mkPkgHeaderFileName c) + ((fst . mkNSandIncHdrs) c)+ (mkPkgCppFileName c) + (mkPkgIncludeHeadersInH c) + (mkPkgIncludeHeadersInCPP c)+ ((snd . mkNSandIncHdrs) c)+ in r -- trace (show r) r +++-- |+extractClassFromType :: Types -> Maybe Class+extractClassFromType Void = Nothing+extractClassFromType SelfType = Nothing+extractClassFromType (CT _ _) = Nothing+extractClassFromType (CPT (CPTClass c) _) = Just c+extractClassFromType (CPT (CPTClassRef c) _) = Just c+++-- | class dependency for a given function +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) =+ Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)+extractClassDep (Static ret _ args) = + Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)+extractClassDep (AliasVirtual ret _ args _) = + Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)+extractClassDep Destructor = + Dep4Func Nothing [] ++-- | +mkModuleDepRaw :: Class -> [Class] +mkModuleDepRaw c = (nub . filter (/= c) . mapMaybe (returnDependency.extractClassDep) . class_funcs) c+ -- ++ concatMap (snd.extractClassDep) fs ++-- | +mkModuleDepHighNonSource :: Class -> [Class] +mkModuleDepHighNonSource c = + let fs = class_funcs c + pkgname = (cabal_pkgname . class_cabal) c + extclasses = (filter (\x-> x /= c && ((/= pkgname) . cabal_pkgname . class_cabal) x) . concatMap (argumentDependency.extractClassDep)) fs+ parents = class_parents c + in nub (parents ++ extclasses) +++-- | +mkModuleDepHighSource :: Class -> [Class] +mkModuleDepHighSource c = + let fs = class_funcs c + pkgname = (cabal_pkgname . class_cabal) c + in nub . filter (\x-> x /= c && not (x `elem` class_parents c) && (((== pkgname) . cabal_pkgname . class_cabal) x)) . concatMap (argumentDependency.extractClassDep) $ fs++-- | +mkModuleDepCpp :: Class -> [Class] +mkModuleDepCpp c = + let fs = class_funcs c + in nub . filter (/= c) $ + mapMaybe (returnDependency.extractClassDep) fs + ++ concatMap (argumentDependency.extractClassDep) fs+ ++ (class_parents c) ++-- | +mkModuleDepFFI4One :: Class -> [Class] +mkModuleDepFFI4One c = + let fs = class_funcs c + in (++) <$> mapMaybe (returnDependency.extractClassDep) + <*> concatMap (argumentDependency.extractClassDep) + $ fs++-- | +mkModuleDepFFI :: Class -> [Class] +mkModuleDepFFI c = + let ps = class_allparents c + alldeps' = (concatMap mkModuleDepFFI4One ps) ++ mkModuleDepFFI4One c+ alldeps = nub (filter (/= c) alldeps')+ in alldeps++ +mkClassModule :: (String,Class->([Namespace],[String]))+ -> Class + -> ClassModule +mkClassModule (pkgname,mkincheaders) c = + let r = (ClassModule <$> getClassModuleBase + <*> pure+ <*> return . mkCIH mkincheaders+ <*> highs_nonsource + <*> raws + <*> highs_source+ <*> ffis + ) c+ in r -- trace (show r) r + + where highs_nonsource = map getClassModuleBase . mkModuleDepHighNonSource+ raws = map getClassModuleBase . mkModuleDepRaw + highs_source = map getClassModuleBase . mkModuleDepHighSource+ 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 + cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)+ cihs = nubBy cmpfunc (concatMap cmCIH ms)+ in (ms,cihs)++mkHSBOOTCandidateList :: [ClassModule] -> [String]+mkHSBOOTCandidateList ms = nub (concatMap cmImportedModulesHighSource ms)
+ lib/FFICXX/Generate/Code/HsFFI.hs view
@@ -0,0 +1,60 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Code.HsFFI+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------+module FFICXX.Generate.Code.HsFFI where+++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+ h = cihSelfHeader header+ allfns = concatMap (virtualFuncs . class_funcs) + (class_allparents c)+ ++ (class_funcs c) + in intercalateWith connRet (hsFFIClassFunc h c) allfns ++genAllHsFFI :: [ClassImportHeader] -> String +genAllHsFFI = intercalateWith connRet2 genHsFFI ++--------++ffistub :: String+ffistub = "foreign import ccall \"$headerfilename$ $classname$_$funcname$\" $hsfuncname$ \n :: $hsargs$"+++hsFFIClassFunc :: FilePath -> Class -> Function -> String +hsFFIClassFunc headerfilename c f = if isAbstractClass c + then ""+ else if (isNewFunc f || isStaticFunc f)+ then render ffistub + [ ("headerfilename",headerfilename) + , ("classname",class_name c)+ , ("funcname", aliasedFuncName c f)+ , ("hsfuncname",hscFuncName c f)+ , ("hsargs", hsFuncTypNoSelf c f) ] + else render ffistub + [ ("headerfilename",headerfilename) + , ("classname",class_name c)+ , ("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) ] -}+
+ lib/FFICXX/Generate/Code/HsFrontEnd.hs view
@@ -0,0 +1,581 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Code.Cpp+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Code.HsFrontEnd where++import Control.Monad.State+import Control.Monad.Reader+import Data.List+import qualified Data.Map as M+import Data.Maybe+import System.FilePath ((<.>))+-- +import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Annotate+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Util+++mkComment :: Int -> String -> String+mkComment indent str + | (not.null) str = + let str_lines = lines str+ indentspace = replicate indent ' ' + commented_lines = + (indentspace ++ "-- | "++head str_lines) : map (\x->indentspace ++ "-- "++x) (tail str_lines)+ in unlines commented_lines + | otherwise = str ++mkPostComment :: String -> String+mkPostComment str + | (not.null) str = + let str_lines = lines str + commented_lines = + ("-- ^ "++head str_lines) : map (\x->"-- "++x) (tail str_lines)+ in unlines commented_lines + | otherwise = str ++ +----------------++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"++genHsFrontDecl :: Class -> Reader AnnotateMap String +genHsFrontDecl c = do + amap <- ask + let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap + let header = render hsClassDeclHeaderTmpl [ ("classname", typeclassName c ) + , ("constraint", classprefix c) + , ("classann", mkComment 0 cann) ] + bodyline func = + let fname = hsFuncName c func + mann = maybe "" id $ M.lookup (PkgMethod,fname) amap+ in render hsClassDeclFuncTmpl + [ ("funcname", hsFuncName c func) + , ("args" , prefixstr func ++ argstr func )+ , ("funcann", mkComment 4 mann) + ] + prefixstr func = + let prefixlst = (snd . mkHsFuncArgType c . genericFuncArgs) func+ ++ (snd . mkHsFuncRetType c ) 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)] + bodylines = map bodyline . virtualFuncs + $ (class_funcs c) + return $ intercalateWith connRet id (header : bodylines) ++++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" + defline func = " " ++ hsFuncName child func ++ " = " ++ hsFuncXformer func ++ " " ++ hscFuncName child func + deflines = (map defline) . virtualFuncs . class_funcs $ parent ++ in intercalateWith connRet id (headline : deflines) + | 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+-}+ +---------------------++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$)" +++{- -- 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+ iname = typeclassName c + ename = existConstructorName c+ tmplName = [ ("rawname",rawname)+ , ("highname",highname)+ , ("interfacename",iname)+ , ("existConstructor",ename)+ ] ++genAllHsFrontInstExistCommon :: [Class] -> String +genAllHsFrontInstExistCommon cs = intercalateWith connRet2 genHsFrontInstExistCommon cs++-------------------++hsClassInstExistVirtualTmpl :: String +hsClassInstExistVirtualTmpl = "instance $Iparent$ (Exist $child$) where\n$method$"++hsClassInstExistVirtualMethodNoSelfTmpl :: String +hsClassInstExistVirtualMethodNoSelfTmpl = " $methodname$ ($exist$ x) = $methodname$ x"++hsClassInstExistVirtualMethodSelfTmpl :: String +hsClassInstExistVirtualMethodSelfTmpl = " $methodname$ ($exist$ x) $args$ = return . $exist$ =<< $methodname$ x $args$"+++genHsFrontInstExistVirtual :: Class -> Class -> String +genHsFrontInstExistVirtual p c = render hsClassInstExistVirtualTmpl tmplName+ where methodstr = intercalateWith connRet (genHsFrontInstExistVirtualMethod p c) + (virtualFuncs.class_funcs $ p)+ tmplName = [ ("Iparent",typeclassName p)+ , ("child",class_name c)+ , ("method", methodstr )+ ] ++genHsFrontInstExistVirtualMethod :: Class -> Class -> Function -> String +genHsFrontInstExistVirtualMethod p c f =+ case f of+ Constructor _ -> error "error in genHsFrontInstExistVirtualMethod" + Destructor -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName+ _ -> case func_ret f of+ SelfType -> render hsClassInstExistVirtualMethodSelfTmpl (tmplName++args)+ _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName+ where tmplName = [ ("methodname", hsFuncName p f)+ , ("exist", existConstructorName c) ]+ args = [ ("args", intercalate " " (take (length (func_args f)) (map (\x -> 'a':(show x)) ([1..] :: [Int]) )))]++genAllHsFrontInstExistVirtual :: [Class] -> DaughterMap -> String +genAllHsFrontInstExistVirtual cs _dmap = intercalateWith connRet2 allinstances cs+ where allinstances c = + let ps = c : class_allparents c+ in intercalateWith connRet2 (\p->genHsFrontInstExistVirtual p c) ps +++---------------------++genHsFrontInstNew :: Class -- ^ only concrete class + -> Reader AnnotateMap (Maybe String)+genHsFrontInstNew c = do + amap <- ask + if null newfuncs + then return Nothing+ else do + let newfunc = head newfuncs+ cann = maybe "" id $ M.lookup (PkgMethod, "new" ++ class_name c) amap+ newfuncann = mkComment 0 cann+ newlinehead = "new" ++ class_name c ++ " :: " ++ argstr newfunc + newlinebody = "new" ++ class_name c ++ " = " + ++ hsFuncXformer newfunc ++ " " + ++ hscFuncName c newfunc + argstr func = intercalateWith connArrow id $+ map (ctypeToHsType c.fst) (genericFuncArgs func)+ ++ ["IO " ++ (ctypeToHsType c.genericFuncRet) func]+ newline = newfuncann ++ "\n" ++ newlinehead ++ "\n" ++ newlinebody + return (Just newline)+ where newfuncs = filter isNewFunc (class_funcs c) ++genAllHsFrontInstNew :: [Class] -- ^ only concrete class + -> Reader AnnotateMap String +genAllHsFrontInstNew = liftM (intercalate "\n\n") . liftM catMaybes . mapM genHsFrontInstNew + +genHsFrontInstNonVirtual :: Class -> Maybe String +genHsFrontInstNonVirtual c + | (not.null) nonvirtualFuncs = + 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] + in Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) nonvirtualFuncs+ | otherwise = Nothing + where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c)++genAllHsFrontInstNonVirtual :: [Class] -> String +genAllHsFrontInstNonVirtual = intercalate "\n\n" . map fromJust . filter isJust . map genHsFrontInstNonVirtual++-----++genHsFrontInstStatic :: Class -> Maybe String +genHsFrontInstStatic c + | (not.null) fs = + 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] + 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 = + let iname = typeclassName c+ (_,rname) = hsClassName c+ in render hsInterfaceCastableInstanceTmpl + [("interfaceName",iname),("rawClassName",rname)]+ | otherwise = "" ++genAllHsFrontInstCastable :: [Class] -> String +genAllHsFrontInstCastable = + intercalateWith connRet2 genHsFrontInstCastable++genHsFrontInstCastableSelf :: Class -> String +genHsFrontInstCastableSelf c + | (not.isAbstractClass) c = + let (cname,rname) = hsClassName c+ in render hsInterfaceCastableInstanceSelfTmpl + [("className",cname)+ ,("rawClassName",rname)]+ | otherwise = "" +++--------------------------++rawToHighDecl :: String+rawToHighDecl = "data $rawname$\nnewtype $highname$ = $highname$ (ForeignPtr $rawname$) deriving (Eq, Ord, Show)"++rawToHighInstance :: String+rawToHighInstance = "instance FPtr $highname$ where\n type Raw $highname$ = $rawname$\n get_fptr ($highname$ fptr) = fptr\n cast_fptr_to_obj = $highname$"+++existableInstance :: String +existableInstance = "instance Existable $highname$ where\n data Exist $highname$ = forall a. (FPtr a, $interfacename$ a) => $existConstructor$ a"+++hsClassRawType :: Class -> String +hsClassRawType c = + let decl = render rawToHighDecl tmplName+ inst1 = render rawToHighInstance tmplName+ in decl `connRet` inst1 + where (highname,rawname) = hsClassName c+ iname = typeclassName c + -- ename = existConstructorName c+ tmplName = [ ("rawname",rawname)+ , ("highname",highname)+ , ("interfacename",iname)+ ] ++hsClassExistType :: Class -> String +hsClassExistType c = render existableInstance tmplName+ where (highname,_rawname) = hsClassName c+ iname = typeclassName c + ename = existConstructorName c+ tmplName = [ ("existConstructor",ename) + , ("highname",highname)+ , ("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) ++mkHsFuncArgType :: Class -> Args -> ([String],[String]) +mkHsFuncArgType c 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 + CPT (CPTClass c') _ -> do + (prefix,n) <- get + let cname = class_name c' + iname = typeclassNameFromStr cname + newname = 'c' : show n+ newprefix1 = iname ++ " " ++ newname + newprefix2 = "FPtr " ++ newname+ put (newprefix1:newprefix2:prefix,n+1)+ return newname+ CPT (CPTClassRef c') _ -> do + (prefix,n) <- get + let cname = class_name c' + iname = typeclassNameFromStr cname + newname = 'c' : show n+ newprefix1 = iname ++ " " ++ newname + newprefix2 = "FPtr " ++ newname+ put (newprefix1:newprefix2:prefix,n+1)+ 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 + SelfType -> ("a",[])+ CPT (CPTClass c') _ -> (cname,[]) where cname = class_name c' + CPT (CPTClassRef c') _ -> (cname,[]) where cname = class_name c' + _ -> (ctypeToHsType c rtyp,[])++ +---------- ++hsInterfaceCastableInstanceTmpl :: String +hsInterfaceCastableInstanceTmpl = + "instance ($interfaceName$ a, FPtr a) => Castable a (Ptr $rawClassName$) where\n cast = unsafeForeignPtrToPtr . castForeignPtr . get_fptr\n uncast = cast_fptr_to_obj . castForeignPtr . unsafePerformIO . newForeignPtr_ \n"++hsInterfaceCastableInstanceSelfTmpl :: String +hsInterfaceCastableInstanceSelfTmpl = + "instance Castable $className$ (Ptr $rawClassName$) where\n cast = unsafeForeignPtrToPtr . castForeignPtr . get_fptr\n uncast = cast_fptr_to_obj . castForeignPtr . unsafePerformIO . newForeignPtr_ \n"+++----------++hsExistentialGADTBodyTmpl :: String +hsExistentialGADTBodyTmpl = " GADT$mother$$daughter$ :: $daughter$ -> GADTType $mother$ $daughter$"+++hsExistentialCastBodyTmpl :: String+hsExistentialCastBodyTmpl = " \"$daughter$\" -> case obj of\n $mother$ fptr -> let obj' = $daughter$ (castForeignPtr fptr :: ForeignPtr Raw$daughter$)\n in return . EGADT$mother$ . GADT$mother$$daughter$ \\$ obj'"++------------+-- upcast --+------------++genHsFrontUpcastClass :: Class -> Reader AnnotateMap String+genHsFrontUpcastClass c = do + -- amap <- ask + let (highname,rawname) = hsClassName c+ upcaststr = render hsUpcastClassTmpl [ ("classname", highname) + , ("ifacename", typeclassName c)+ , ("rawclassname", rawname) + , ("space", replicate (length highname+11) ' ' ) ] + return upcaststr++genAllHsFrontUpcastClass :: [Class] -> Reader AnnotateMap String+genAllHsFrontUpcastClass = intercalateWithM connRet2 genHsFrontUpcastClass+++hsUpcastClassTmpl :: String +hsUpcastClassTmpl = "upcast$classname$ :: (FPtr a, $ifacename$ a) => a -> $classname$\nupcast$classname$ h = let fh = get_fptr h\n$space$ fh2 :: ForeignPtr $rawclassname$ = castForeignPtr fh\n$space$in cast_fptr_to_obj fh2"+++--------------+-- downcast --+--------------++genHsFrontDowncastClass :: Class -> Reader AnnotateMap String+genHsFrontDowncastClass c = do + -- amap <- ask + let (highname,rawname) = hsClassName c+ downcaststr = render hsDowncastClassTmpl [ ("classname", highname) + , ("ifacename", typeclassName c)+ , ("rawclassname", rawname) + , ("space", replicate (length highname+13) ' ' ) ] + return downcaststr++genAllHsFrontDowncastClass :: [Class] -> Reader AnnotateMap String+genAllHsFrontDowncastClass = intercalateWithM connRet2 genHsFrontDowncastClass+++hsDowncastClassTmpl :: String +hsDowncastClassTmpl = "downcast$classname$ :: (FPtr a, $ifacename$ a) => $classname$ -> a \ndowncast$classname$ h = let fh = get_fptr h\n$space$ fh2 = castForeignPtr fh\n$space$in cast_fptr_to_obj fh2"++------------+-- Export --+------------++genExport :: Class -> String +genExport c =+ let methodstr = if null . (filter isVirtualFunc) $ (class_funcs c) + 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 + ++ "\n" ++ genExportConstructorAndNonvirtual c + ++ "\n" ++ genExportStatic c ++-- | constructor and non-virtual function +genExportConstructorAndNonvirtual :: Class -> String +genExportConstructorAndNonvirtual c = + intercalateWith connRet (\x->indent++", "++x) fns+ where indent = replicate 2 ' ' + fs = class_funcs c+ fns = map (aliasedFuncName c) (constructorFuncs fs + ++ nonVirtualNotNewFuncs fs)++-- | staic function export list +genExportStatic :: Class -> String +genExportStatic c = + intercalateWith connRet (\x->indent++", "++x) fns+ where indent = replicate 2 ' ' + fs = class_funcs c+ fns = map (aliasedFuncName c) (staticFuncs fs) ++++++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 ++importSOURCEOneClass :: String -> String -> String +importSOURCEOneClass mname typ = "import {-# SOURCE #-} " ++ mname <.> typ +++genImportInModule :: [Class] -> String +genImportInModule cs = + let genImportOneClass c = + let n = getClassModuleBase c -- class_name c + in intercalateWith connRet (importOneClass n) $+ ["RawType", "Interface", "Implementation"]+ in intercalate "\n" (map genImportOneClass cs)+++genImportInFFI :: ClassModule -> String+genImportInFFI m = + let modlst = cmImportedModulesForFFI m+ in intercalateWith connRet (\x->importOneClass x "RawType") modlst+++genImportInInterface :: ClassModule -> String+genImportInInterface m = + let modlstraw = cmImportedModulesRaw m+ modlstparent = cmImportedModulesHighNonSource m + modlsthigh = cmImportedModulesHighSource m+ getImportOneClassRaw mname = + intercalateWith connRet (importOneClass mname) ["RawType"]+ getImportOneClassHigh mname = + intercalateWith connRet (importOneClass mname) ["Interface"]+ getImportSOURCEOneClassHigh mname = + intercalateWith connRet (importSOURCEOneClass mname) ["Interface"]+ in importOneClass (cmModule m) "RawType"+ `connRet`+ intercalateWith connRet getImportOneClassRaw modlstraw+ `connRet`+ intercalateWith connRet getImportOneClassHigh modlstparent + `connRet` + "---- ============ ----" + `connRet` + intercalateWith connRet getImportSOURCEOneClassHigh modlsthigh++-- |+genImportInCast :: ClassModule -> String +genImportInCast m = + importOneClass (cmModule m) "RawType"+ `connRet` + importOneClass (cmModule m) "Interface"++-- | +genImportInImplementation :: ClassModule -> String+genImportInImplementation m = + let modlstraw' = cmImportedModulesForFFI m+ modlsthigh = nub $ map getClassModuleBase $ concatMap class_allparents (cmClass m)+ modlstraw = filter (not.(flip elem modlsthigh)) modlstraw' + getImportOneClassRaw mname = + intercalateWith connRet (importOneClass mname) + ["RawType","Cast","Interface"]+ getImportOneClassHigh mname = + intercalateWith connRet (importOneClass mname) + ["RawType","Cast","Interface"] + in importOneClass (cmModule m) "RawType"+ `connRet`+ importOneClass (cmModule m) "FFI"+ `connRet`+ importOneClass (cmModule m) "Interface"+ `connRet`+ importOneClass (cmModule m) "Cast"+ `connRet`+ intercalateWith connRet getImportOneClassRaw modlstraw+ `connRet` + intercalateWith connRet getImportOneClassHigh modlsthigh++-- | +genImportInExistential :: DaughterMap -> ClassModule -> String+genImportInExistential dmap m = + let daughters = concat . catMaybes $ (map (flip M.lookup dmap . getClassModuleBase) (cmClass m))+ alldaughters' = nub . map getClassModuleBase $ daughters+ -- alldaughters = filter ((&&) <$> (/= "TClass") <*> (/= "TObject")) alldaughters'+ alldaughters = alldaughters'+ getImportOneClass mname = + intercalateWith connRet (importOneClass mname) + ["RawType", "Cast", "Interface", "Implementation"]+ in intercalateWith connRet getImportOneClass alldaughters++++
+ lib/FFICXX/Generate/Code/MethodDef.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Code.MethodDef+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++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 +++-- Function Declaration and Definition++funcToDecl :: Class -> Function -> String +funcToDecl c func + | isNewFunc func || isStaticFunc func = + let tmpl = "$returntype$ Type ## _$funcname$ ( $args$ )" + in render tmpl [ ("returntype", rettypeToString (genericFuncRet func)) + , ("funcname", aliasedFuncName c func) + , ("args", argsToStringNoSelf (genericFuncArgs func)) ] + | otherwise = + let tmpl = "$returntype$ Type ## _$funcname$ ( $args$ )" + in render tmpl [ ("returntype", rettypeToString (genericFuncRet func)) + , ("funcname", aliasedFuncName c func) + , ("args", argsToString (genericFuncArgs func)) ] ++++funcsToDecls :: Class -> [Function] -> String +funcsToDecls c = intercalateWith connSemicolonBSlash (funcToDecl c)+++funcToDef :: Class -> Function -> String+funcToDef c func + | isNewFunc func = + let declstr = funcToDecl c func+ callstr = "(" ++ argsToCallString (genericFuncArgs func) ++ ")"+ returnstr = "Type * newp = new Type " ++ callstr ++ "; \\\nreturn to_nonconst<Type ## _t, Type >(newp);"+ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | isDeleteFunc func = + let declstr = funcToDecl c func+ returnstr = "delete (to_nonconst<Type,Type ## _t>(p)) ; "+ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | isStaticFunc func = + let declstr = funcToDecl c func+ callstr = cppFuncName c func ++ "("+ ++ argsToCallString (genericFuncArgs func) + ++ ")"+ returnstr = case (genericFuncRet func) 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++");" + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | otherwise = + let declstr = funcToDecl c func+ callstr = -- "to_nonconst<Type,Type ## _t>(p)->" + "TYPECASTMETHOD(Type,"++ aliasedFuncName c func ++ "," ++ class_name c ++ ")(p)->"+ ++ cppFuncName c func ++ "("+ ++ argsToCallString (genericFuncArgs func) + ++ ")"+ returnstr = case (genericFuncRet func) 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++");" + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] ++++funcsToDefs :: Class -> [Function] -> String+funcsToDefs c = intercalateWith connBSlash (funcToDef c)++++++
+ lib/FFICXX/Generate/Config.hs view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Config+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------+++module FFICXX.Generate.Config where++data FFICXXConfig = FFICXXConfig { + fficxxconfig_scriptBaseDir :: FilePath, + fficxxconfig_workingDir :: FilePath, + fficxxconfig_installBaseDir :: FilePath+} deriving Show+
+ lib/FFICXX/Generate/Generator/ContentMaker.hs view
@@ -0,0 +1,408 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Generator.ContentMaker+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Generator.ContentMaker where ++import Control.Applicative+import Control.Lens (set,at)+import Control.Monad.Trans.Reader+import qualified Data.Map as M+import Data.List +import Data.List.Split (splitOn) +import Data.Maybe+import System.FilePath +import Text.StringTemplate hiding (render)+-- +import FFICXX.Generate.Code.Cpp+import FFICXX.Generate.Code.HsFFI +import FFICXX.Generate.Code.HsFrontEnd+import FFICXX.Generate.Type.Annotate+import FFICXX.Generate.Type.Class+import qualified FFICXX.Generate.Type.PackageInterface as T+import FFICXX.Generate.Util+--++srcDir :: FilePath -> FilePath+srcDir installbasedir = installbasedir </> "src" ++csrcDir :: FilePath -> FilePath+csrcDir installbasedir = installbasedir </> "csrc" ++moduleTemplate :: String +moduleTemplate = "module.hs"++hsbootTemplate :: String+hsbootTemplate = "Class.hs-boot"++-- cabalTemplate :: String +-- cabalTemplate = "Pkg.cabal"++declarationTemplate :: String+declarationTemplate = "Module.h"++typeDeclHeaderFileName :: String+typeDeclHeaderFileName = "PkgType.h"++declbodyTemplate :: String+declbodyTemplate = "declbody.h"++funcdeclTemplate :: String+funcdeclTemplate = "funcdecl.h" ++definitionTemplate :: String+definitionTemplate = "Pkg.cpp"++classDefTemplate :: String+classDefTemplate = "classdef.cpp"++functionTemplate :: String+functionTemplate = "function.cpp" ++funcbodyTemplate :: String+funcbodyTemplate = "functionbody.cpp"++headerFileName :: String+headerFileName = "Module.h"++cppFileName :: String+cppFileName = "Pkg.cpp" ++hscFileName :: String+hscFileName = "FFI.hsc"++hsFileName :: String+hsFileName = "Implementation.hs"++typeHsFileName :: String+typeHsFileName = "Interface.hs"++existHsFileName :: String +existHsFileName = "Existential.hs"++rawtypeHsFileName :: String+rawtypeHsFileName = "RawType.hs"++ffiHscFileName :: String +ffiHscFileName = "FFI.hsc"++interfaceHsFileName :: String+interfaceHsFileName = "Interface.hs"++castHsFileName :: String+castHsFileName = "Cast.hs"++implementationHsFileName :: String +implementationHsFileName = "Implementation.hs"++existentialHsFileName :: String +existentialHsFileName = "Existential.hs"+++---- common function for daughter+++-- | +mkGlobal :: [Class] -> ClassGlobal+mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap +++-- | +mkDaughterDef :: ((String,[Class]) -> String) + -> DaughterMap + -> String +mkDaughterDef f m = + let lst = M.toList m + f' (x,xs) = f (x,filter (not.isAbstractClass) xs) + in (concatMap f' lst)++-- | +mkParentDef :: ((Class,Class)->String) -> Class -> String+mkParentDef f cls = g (class_allparents cls,cls)+ where g (ps,c) = concatMap (\p -> f (p,c)) ps+++-- | +mkProtectedFunctionList :: Class -> String +mkProtectedFunctionList c = + (unlines + . map (\x->"#define IS_" ++ class_name c ++ "_" ++ x ++ "_PROTECTED ()") + . unProtected . class_protected) c +++++-- |+mkTypeDeclHeader :: STGroup String -- -> ClassGlobal + -> T.TypeMacro -- ^ typemacro + -> [Class]+ -> String +mkTypeDeclHeader templates (T.TypMcro typemacro) classes =+ let typeDeclBodyStr = genAllCppHeaderTmplType classes + in renderTemplateGroup + templates + [ ("typeDeclBody", typeDeclBodyStr ) + , ("typemacro", typemacro ) ++ ] + typeDeclHeaderFileName++-- | +mkDeclHeader :: STGroup String + -- -> ClassGlobal + -> T.TypeMacro -- ^ typemacro prefix + -> String -- ^ C prefix + -> ClassImportHeader + -> String +mkDeclHeader templates (T.TypMcro typemacroprefix) cprefix header =+ let classes = [cihClass header]+ aclass = cihClass header+ typemacrostr = typemacroprefix ++ class_name aclass ++ "__" + declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") $+ cihIncludedHPkgHeadersInH header+ declDefStr = genAllCppHeaderTmplVirtual classes + `connRet2`+ genAllCppHeaderTmplNonVirtual classes + `connRet2` + genAllCppDefTmplVirtual classes+ `connRet2`+ genAllCppDefTmplNonVirtual classes+ -- dsmap = cgDaughterSelfMap cglobal+ classDeclsStr = if class_name aclass /= "Deletable"+ then mkParentDef genCppHeaderInstVirtual aclass + `connRet2`+ genCppHeaderInstVirtual (aclass, aclass)+ `connRet2` + genAllCppHeaderInstNonVirtual classes+ else "" + declBodyStr = declDefStr + `connRet2` + classDeclsStr + in renderTemplateGroup + templates + [ ("typemacro", typemacrostr)+ , ("cprefix", cprefix)+ , ("declarationheader", declHeaderStr ) + , ("declarationbody", declBodyStr ) ] + declarationTemplate++-- | +mkDefMain :: STGroup String + -> ClassImportHeader + -> String +mkDefMain templates header =+ let classes = [cihClass header]+ headerStr = genAllCppHeaderInclude header ++ "\n#include \"" ++ (cihSelfHeader header) ++ "\"" + namespaceStr = (concatMap (\x->"using namespace " ++ unNamespace x ++ ";\n") . cihNamespace) header+ aclass = cihClass header+ cppBody = mkProtectedFunctionList (cihClass header) + `connRet`+ mkParentDef genCppDefInstVirtual (cihClass header)+ `connRet` + if isAbstractClass aclass + then "" + else genCppDefInstVirtual (aclass, aclass)+ `connRet`+ genAllCppDefInstNonVirtual classes+ in renderTemplateGroup + templates + [ ("header" , headerStr ) + , ("namespace", namespaceStr ) + , ("cppbody", cppBody ) + , ("modname", class_name (cihClass header)) ] + definitionTemplate++-- | +mkFFIHsc :: STGroup String + -> ClassModule + -> String +mkFFIHsc templates m = + renderTemplateGroup templates + [ ("ffiHeader", ffiHeaderStr)+ , ("ffiImport", ffiImportStr)+ , ("cppInclude", cppIncludeStr)+ , ("hsFunctionBody", genAllHsFFI headers) ]+ ffiHscFileName+ where mname = cmModule m+ -- classes = cmClass m+ headers = cmCIH m+ ffiHeaderStr = "module " ++ mname <.> "FFI where\n"+ ffiImportStr = "import " ++ mname <.> "RawType\n"+ ++ genImportInFFI m+ cppIncludeStr = genModuleIncludeHeader headers++-- | +mkRawTypeHs :: STGroup String + -> ClassModule + -> String+mkRawTypeHs templates m = + renderTemplateGroup templates [ ("rawtypeHeader", rawtypeHeaderStr) + , ("rawtypeBody", rawtypeBodyStr)] rawtypeHsFileName+ where rawtypeHeaderStr = "module " ++ cmModule m <.> "RawType where\n"+ classes = cmClass m+ rawtypeBodyStr = + intercalateWith connRet2 hsClassRawType (filter (not.isAbstractClass) classes)++-- | +mkInterfaceHs :: AnnotateMap + -> STGroup String + -> ClassModule + -> String +mkInterfaceHs amap templates m = + renderTemplateGroup templates [ ("ifaceHeader", ifaceHeaderStr) + , ("ifaceImport", ifaceImportStr)+ , ("ifaceBody", ifaceBodyStr)] "Interface.hs" + where ifaceHeaderStr = "module " ++ cmModule m <.> "Interface where\n" + classes = cmClass m+ ifaceImportStr = genImportInInterface m+ ifaceBodyStr = + runReader (genAllHsFrontDecl classes) amap + `connRet2`+ intercalateWith connRet hsClassExistType (filter (not.isAbstractClass) classes) + `connRet2`+ runReader (genAllHsFrontUpcastClass (filter (not.isAbstractClass) classes)) amap + `connRet2`+ runReader (genAllHsFrontDowncastClass (filter (not.isAbstractClass) classes)) amap++-- | +mkCastHs :: STGroup String -> ClassModule -> String +mkCastHs templates m = + renderTemplateGroup templates [ ("castHeader", castHeaderStr) + , ("castImport", castImportStr)+ , ("castBody", castBodyStr) ] + castHsFileName+ where castHeaderStr = "module " ++ cmModule m <.> "Cast where\n" + classes = cmClass m+ castImportStr = genImportInCast m+ castBodyStr = + genAllHsFrontInstCastable classes + `connRet2`+ intercalateWith connRet2 genHsFrontInstCastableSelf classes++-- | +mkImplementationHs :: AnnotateMap + -> STGroup String -- ^ template + -> ClassModule + -> String+mkImplementationHs amap templates m = + renderTemplateGroup templates + [ ("implHeader", implHeaderStr) + , ("implImport", implImportStr)+ , ("implBody", implBodyStr ) ]+ "Implementation.hs"+ where classes = cmClass m+ implHeaderStr = "module " ++ cmModule m <.> "Implementation where\n" + implImportStr = genImportInImplementation m+ f y = intercalateWith connRet (flip genHsFrontInst y) (y:class_allparents y )+ g y = intercalateWith connRet (flip genHsFrontInstExistVirtual y) (y:class_allparents y )++ implBodyStr = + intercalateWith connRet2 f classes+ `connRet2` + intercalateWith connRet2 g (filter (not.isAbstractClass) classes)+ `connRet2`+ runReader (genAllHsFrontInstNew classes) amap+ `connRet2`+ genAllHsFrontInstNonVirtual classes+ `connRet2`+ intercalateWith connRet id (mapMaybe genHsFrontInstStatic classes)+ `connRet2`+ genAllHsFrontInstExistCommon (filter (not.isAbstractClass) classes)+ +-- | +mkExistentialEach :: STGroup String + -> Class + -> [Class] + -> String +mkExistentialEach templates mother daughters = + let makeOneDaughterGADTBody daughter = render hsExistentialGADTBodyTmpl + [ ( "mother", class_name mother ) + , ( "daughter", class_name daughter ) ] + makeOneDaughterCastBody daughter = render hsExistentialCastBodyTmpl+ [ ( "mother", class_name mother ) + , ( "daughter", class_name daughter) ] + gadtBody = intercalate "\n" (map makeOneDaughterGADTBody daughters)+ castBody = intercalate "\n" (map makeOneDaughterCastBody daughters)+ str = renderTemplateGroup + templates + [ ( "mother" , class_name mother ) + , ( "GADTbody" , gadtBody ) + , ( "castbody" , castBody ) ]+ "ExistentialEach.hs" + in str++-- | +mkExistentialHs :: STGroup String + -> ClassGlobal + -> ClassModule + -> String+mkExistentialHs templates cglobal m = + let classes = filter (not.isAbstractClass) (cmClass m)+ dsmap = cgDaughterSelfMap cglobal+ makeOneMother :: Class -> String + makeOneMother mother = + let daughters = case M.lookup (getClassModuleBase mother) dsmap of + Nothing -> error "error in mkExistential"+ Just lst -> filter (not.isAbstractClass) lst+ str = mkExistentialEach templates mother daughters+ in str + existEachBody = intercalateWith connRet makeOneMother classes+ existHeaderStr = "module " ++ cmModule m <.> "Existential where"+ existImportStr = genImportInExistential dsmap m+ hsfilestr = renderTemplateGroup + templates + [ ("existHeader", existHeaderStr)+ , ("existImport", existImportStr)+ , ("modname", cmModule m)+ , ( "existEachBody" , existEachBody) ]+ "Existential.hs" + in hsfilestr++-- | +mkInterfaceHSBOOT :: STGroup String -> String -> String +mkInterfaceHSBOOT templates mname = + let cname = last (splitOn "." mname)+ hsbootbodystr = "class " ++ 'I':cname ++ " a" + hsbootstr = renderTemplateGroup + templates + [ ("moduleName", mname <.> "Interface") + , ("hsBootBody", hsbootbodystr)+ ]+ hsbootTemplate+ in hsbootstr ++++-- | +mkModuleHs :: STGroup String + -> ClassModule + -> String +mkModuleHs templates m = + let str = renderTemplateGroup + templates + [ ("moduleName", cmModule m) + , ("exportList", genExportList (cmClass m)) + , ("importList", genImportInModule (cmClass m))+ ]+ moduleTemplate + in str+ +-- |+mkPackageInterface :: T.PackageInterface + -> T.PackageName + -> [ClassImportHeader] + -> T.PackageInterface+mkPackageInterface pinfc pkgname = foldr f pinfc + where f cih repo = + let name = (class_name . cihClass) cih + header = cihSelfHeader cih + in set (at (pkgname,T.ClsName name)) (Just (T.HdrName header)) repo+
+ lib/FFICXX/Generate/Generator/Driver.hs view
@@ -0,0 +1,210 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Generator.Driver+-- Copyright : (c) 2011-2013 Ian-Woo Kim+-- +-- License : BSD3+-- Maintainer : ianwookim@gmail.com+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Generator.Driver where++import Control.Applicative ((<$>))+import Control.Monad (when)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Digest.Pure.MD5+import System.Directory +import System.FilePath+import System.IO+import System.Process+import Text.StringTemplate+-- import Text.StringTemplate.Helpers+--+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Annotate+import FFICXX.Generate.Type.PackageInterface +import FFICXX.Generate.Generator.ContentMaker +import FFICXX.Generate.Util++++----+---- Header and Cpp file+----++-- | +writeTypeDeclHeaders :: STGroup String + -> FilePath + -> TypeMacro -- ^ type macro + -> String -- ^ cprefix + -> [ClassImportHeader]+ -> IO ()+writeTypeDeclHeaders templates wdir typemacro cprefix headers = do + let fn = wdir </> cprefix ++ "Type.h"+ classes = map cihClass headers+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkTypeDeclHeader templates typemacro classes)++-- | +writeDeclHeaders :: STGroup String + -> FilePath + -> TypeMacro + -> String -- ^ c prefix + -> ClassImportHeader+ -> IO () +writeDeclHeaders templates wdir typemacroprefix cprefix header = do + let fn = wdir </> cihSelfHeader header+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkDeclHeader templates typemacroprefix cprefix header)++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)++-- | +writeRawTypeHs :: STGroup String -> FilePath -> ClassModule -> IO ()+writeRawTypeHs templates wdir m = do+ let fn = wdir </> cmModule m <.> rawtypeHsFileName+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkRawTypeHs templates m) ++-- | +writeFFIHsc :: STGroup String -> FilePath -> ClassModule -> IO ()+writeFFIHsc templates wdir m = do + let fn = wdir </> cmModule m <.> ffiHscFileName+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkFFIHsc templates m)++-- | +writeInterfaceHs :: AnnotateMap -> STGroup String -> FilePath + -> ClassModule + -> IO ()+writeInterfaceHs amap templates wdir m = do + let fn = wdir </> cmModule m <.> interfaceHsFileName+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkInterfaceHs amap templates m)++-- |+writeCastHs :: STGroup String -> FilePath -> ClassModule -> IO ()+writeCastHs templates wdir m = do + let fn = wdir </> cmModule m <.> castHsFileName+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkCastHs templates m)++-- | +writeImplementationHs :: AnnotateMap + -> STGroup String + -> FilePath + -> ClassModule + -> IO ()+writeImplementationHs amap templates wdir m = do + let fn = wdir </> cmModule m <.> implementationHsFileName+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkImplementationHs amap templates m)++-- | +writeExistentialHs :: STGroup String + -> ClassGlobal + -> FilePath + -> ClassModule + -> IO ()+writeExistentialHs templates cglobal wdir m = do + let fn = wdir </> cmModule m <.> existentialHsFileName+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkExistentialHs templates cglobal m)++-- | +writeInterfaceHSBOOT :: STGroup String -> FilePath -> String -> IO ()+writeInterfaceHSBOOT templates wdir mname = do + let fn = wdir </> mname <.> "Interface" <.> "hs-boot"+ withFile fn WriteMode $ \h -> hPutStrLn h (mkInterfaceHSBOOT templates mname)++-- |+writeModuleHs :: STGroup String -> FilePath -> ClassModule -> IO () +writeModuleHs templates wdir m = do + let fn = wdir </> cmModule m <.> "hs"+ withFile fn WriteMode $ \h -> do + hPutStrLn h (mkModuleHs templates m)++writePkgHs :: String -- ^ summary module + -> STGroup String + -> FilePath + -> [ClassModule] + -> IO () +writePkgHs modname templates wdir mods = 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+++notExistThenCreate :: FilePath -> IO () +notExistThenCreate dir = do + b <- doesDirectoryExist dir+ if b then return () else system ("mkdir -p " ++ dir) >> return ()+++{- +-- | now only create directory+copyPredefined :: FilePath -> FilePath -> String -> IO () +copyPredefined _tdir _ddir _prefix = do + return () + -- notExistThenCreate (ddir </> prefix)+ -- copyFile (tdir </> "TypeCast.hs" ) (ddir </> prefix </> "TypeCast.hs") +-}++copyFileWithMD5Check :: FilePath -> FilePath -> IO () +copyFileWithMD5Check src tgt = do+ b <- doesFileExist tgt + if b + then do + srcmd5 <- md5 <$> L.readFile src + tgtmd5 <- md5 <$> L.readFile tgt + if srcmd5 == tgtmd5 then return () else copyFile src tgt + else copyFile src tgt +++copyCppFiles :: FilePath -> FilePath -> String -> ClassImportHeader -> IO ()+copyCppFiles wdir ddir cprefix header = do + let thfile = cprefix ++ "Type.h"+ hfile = cihSelfHeader header+ cppfile = cihSelfCpp header+ copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile) + copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) + copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)++copyModule :: FilePath -> FilePath -> String -> ClassModule -> IO ()+copyModule wdir ddir summarymod m = do + let modbase = cmModule m + let onefilecopy fname = do + let (fnamebody,fnameext) = splitExtension fname+ (mdir,mfile) = moduleDirFile fnamebody+ origfpath = wdir </> fname+ (mfile',_mext') = splitExtension mfile+ newfpath = ddir </> mdir </> mfile' ++ fnameext + b <- doesFileExist origfpath + when b $ do + notExistThenCreate (ddir </> mdir) + copyFileWithMD5Check origfpath newfpath ++ onefilecopy $ modbase ++ ".hs"+ onefilecopy $ modbase ++ ".RawType.hs"+ onefilecopy $ modbase ++ ".FFI.hsc"+ onefilecopy $ modbase ++ ".Interface.hs"+ onefilecopy $ modbase ++ ".Cast.hs"+ onefilecopy $ modbase ++ ".Implementation.hs"+ onefilecopy $ modbase ++ ".Interface.hs-boot"+ onefilecopy $ summarymod <.> "hs"+ return ()
+ lib/FFICXX/Generate/QQ/Verbatim.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.QQ.Verbatim+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.QQ.Verbatim where++import Language.Haskell.TH.Quote+import Language.Haskell.TH.Lib++verbatim :: QuasiQuoter+verbatim = QuasiQuoter { + quoteExp = litE . stringL+-- , quotePat = litP . stringP+ } +
+ lib/FFICXX/Generate/Type/Annotate.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Type.Annotate+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Type.Annotate where++import qualified Data.Map as M++data PkgType = PkgModule | PkgClass | PkgMethod + deriving (Show,Eq,Ord)++type AnnotateMap = M.Map (PkgType,String) String+++
+ lib/FFICXX/Generate/Type/Class.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Type.Class+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Type.Class where++import Control.Applicative ((<$>),(<*>))+import Data.Char+import Data.List +import Data.Monoid +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+ deriving Show ++data CPPTypes = CPTClass Class + | CPTClassRef Class + deriving Show++data IsConst = Const | NoConst+ deriving Show++data Types = Void + | SelfType+ | CT CTypes IsConst + | CPT CPPTypes IsConst+ deriving Show++cvarToStr :: CTypes -> IsConst -> String -> String+cvarToStr ctyp isconst varname = (ctypToStr ctyp isconst) `connspace` varname ++ctypToStr :: CTypes -> IsConst -> String+ctypToStr ctyp isconst = + let typword = case ctyp of + CTString -> "char *"+ CTInt -> "int " + CTUInt -> "unsigned int "+ CTDouble -> "double" + CTBool -> "int" -- Currently available solution+ CTDoubleStar -> "double *"+ CTVoidStar -> "void *"+ CTIntStar -> "int *"+ CTCharStarStar -> "char **"+ in case isconst of + Const -> "const" `connspace` typword + NoConst -> typword +++self_ :: Types +self_ = SelfType++cstring_ :: Types+cstring_ = CT CTString Const ++cint_ :: Types+cint_ = CT CTInt Const++int_ :: Types +int_ = CT CTInt NoConst++uint_ :: Types+uint_ = CT CTUInt NoConst++short_ :: Types+short_ = int_++cdouble_ :: Types+cdouble_ = CT CTDouble Const++double_ :: Types+double_ = CT CTDouble NoConst++doublep_ :: Types+doublep_ = CT CTDoubleStar NoConst++float_ :: Types+float_ = double_++bool_ :: Types +bool_ = CT CTBool NoConst ++void_ :: Types+void_ = Void ++voidp_ :: Types +voidp_ = CT CTVoidStar NoConst++intp_ :: Types +intp_ = CT CTIntStar NoConst++charpp_ :: Types+charpp_ = CT CTCharStarStar NoConst++self :: String -> (Types, String)+self var = (self_, var)++voidp :: String -> (Types,String) +voidp var = (voidp_ , var)++cstring :: String -> (Types,String)+cstring var = (cstring_ , var)++cint :: String -> (Types,String)+cint var = (cint_ , var) ++int :: String -> (Types,String)+int var = (int_ , var)++uint :: String -> (Types,String)+uint var = (uint_ , var)++short :: String -> (Types,String)+short = int++cdouble :: String -> (Types,String)+cdouble var = (cdouble_ , var)++double :: String -> (Types,String)+double var = (double_ , var)++doublep :: String -> (Types,String)+doublep var = (doublep_ , var)++float :: String -> (Types,String)+float = double++bool :: String -> (Types,String)+bool var = (bool_ , var)++intp :: String -> (Types, String) +intp var = (intp_ , var)++charpp :: String -> (Types, String)+charpp var = (charpp_, var)++cppclass_ :: Class -> Types+cppclass_ c = CPT (CPTClass c) NoConst++cppclass :: Class -> String -> (Types, String)+cppclass c vname = ( cppclass_ c, vname)++cppclassconst :: Class -> String -> (Types, String) +cppclassconst c vname = ( CPT (CPTClass c) Const, vname)++cppclassref_ :: Class -> Types +cppclassref_ c = CPT (CPTClassRef c) NoConst ++cppclassref :: Class -> String -> (Types, String) +cppclassref c vname = (cppclassref_ c, vname)+++hsCTypeName :: CTypes -> String +hsCTypeName CTString = "CString" +hsCTypeName CTInt = "CInt"+hsCTypeName CTUInt = "CUInt" +hsCTypeName CTDouble = "CDouble"+hsCTypeName CTDoubleStar = "(Ptr CDouble)"+hsCTypeName CTBool = "CInt"+hsCTypeName CTVoidStar = "(Ptr ())"+hsCTypeName CTIntStar = "(Ptr CInt)"+hsCTypeName CTCharStarStar = "(Ptr (CString))"++++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 ++-------------++type Args = [(Types,String)]++data Function = Constructor { func_args :: Args } + | Virtual { func_ret :: Types+ , func_name :: String+ , func_args :: Args } + | NonVirtual { func_ret :: Types + , func_name :: String+ , func_args :: Args }+ | Static { func_ret :: Types + , func_name :: String+ , func_args :: Args }+ | AliasVirtual { func_ret :: Types + , func_name :: String+ , func_args :: Args + , func_alias :: String }+ | Destructor + deriving Show++-- | Protected { func_name :: String } +++ +isNewFunc :: Function -> Bool +isNewFunc (Constructor _ ) = True +isNewFunc _ = False++isDeleteFunc :: Function -> Bool +isDeleteFunc Destructor = True +isDeleteFunc _ = False+ +isVirtualFunc :: Function -> Bool +isVirtualFunc (Destructor) = True+isVirtualFunc (Virtual _ _ _) = True +isVirtualFunc (AliasVirtual _ _ _ _) = True +isVirtualFunc _ = False ++isStaticFunc :: Function -> Bool +isStaticFunc (Static _ _ _) = True+isStaticFunc _ = False++virtualFuncs :: [Function] -> [Function] +virtualFuncs = filter isVirtualFunc ++constructorFuncs :: [Function] -> [Function]+constructorFuncs = filter isNewFunc++nonVirtualNotNewFuncs :: [Function] -> [Function]+nonVirtualNotNewFuncs = + filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x )++staticFuncs :: [Function] -> [Function] +staticFuncs = filter isStaticFunc++argToString :: (Types,String) -> String +argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname +argToString (SelfType, varname) = "Type ## _p " ++ varname+argToString (CPT (CPTClass c) isconst, varname) = case isconst of + Const -> "const_" ++ cname ++ "_p " ++ varname + NoConst -> cname ++ "_p " ++ varname+ where cname = class_name c +argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of + Const -> "const_" ++ cname ++ "_p " ++ varname + NoConst -> cname ++ "_p " ++ varname+ where cname = class_name c +argToString _ = error "undefined argToString"++argsToString :: Args -> String +argsToString args = + let args' = (SelfType, "p") : args + in intercalateWith conncomma argToString args'++argsToStringNoSelf :: Args -> String +argsToStringNoSelf = intercalateWith conncomma argToString +++argToCallString :: (Types,String) -> String+argToCallString (CPT (CPTClass c) _,varname) = + "to_nonconst<"++str++","++str++"_t>("++varname++")" where str = class_name c+argToCallString (CPT (CPTClassRef c) _,varname) = + "to_nonconstref<"++str++","++str++"_t>(*"++varname++")" where str = class_name c+argToCallString (_,varname) = varname++argsToCallString :: Args -> String+argsToCallString = intercalateWith conncomma argToCallString+++rettypeToString :: Types -> String +rettypeToString (CT ctyp isconst) = ctypToStr ctyp isconst+rettypeToString Void = "void"+rettypeToString SelfType = "Type ## _p"+rettypeToString (CPT (CPTClass c) _) = str ++ "_p"+ where str = class_name c +rettypeToString (CPT (CPTClassRef c) _) = str ++ "_p" + where str = class_name c ++--------++newtype ProtectedMethod = Protected { unProtected :: [String] } + deriving (Monoid) ++data Cabal = Cabal { cabal_pkgname :: String+ , cabal_cheaderprefix :: String+ , cabal_moduleprefix :: String } +++data Class = Class { class_cabal :: Cabal + , class_name :: String+ , class_parents :: [Class] + , class_protected :: ProtectedMethod+ , class_funcs :: [Function] + }+ | AbstractClass { class_cabal :: Cabal + , class_name :: String+ , class_parents :: [Class]+ , class_protected :: ProtectedMethod+ , class_funcs :: [Function] }++newtype Namespace = NS { unNamespace :: String } deriving (Show)++data ClassImportHeader = ClassImportHeader+ { cihClass :: Class + , cihSelfHeader :: String + , cihNamespace :: [Namespace] + , cihSelfCpp :: String+ , cihIncludedHPkgHeadersInH :: [String] + , cihIncludedHPkgHeadersInCPP :: [String] + , cihIncludedCPkgHeaders :: [String] + } deriving (Show)++data ClassModule = ClassModule + { cmModule :: String+ , cmClass :: [Class] + , cmCIH :: [ClassImportHeader] + , cmImportedModulesHighNonSource :: [String]+ , cmImportedModulesRaw :: [String] + , cmImportedModulesHighSource :: [String]+ , cmImportedModulesForFFI :: [String]+ } deriving (Show)++data ClassGlobal = ClassGlobal + { cgDaughterSelfMap :: DaughterMap + , cgDaughterMap :: DaughterMap+ } ++-- | Check abstract class++isAbstractClass :: Class -> Bool +isAbstractClass (Class _ _ _ _ _) = False +isAbstractClass (AbstractClass _ _ _ _ _ ) = True ++instance Show Class where+ show x = show (class_name x)++instance Eq Class where+ (==) x y = class_name x == class_name y++instance Ord Class where+ compare x y = compare (class_name x) (class_name y)++type DaughterMap = M.Map String [Class] ++class_allparents :: Class -> [Class] +class_allparents c = let ps = class_parents c+ in if null ps + then []+ else nub (ps ++ (concatMap class_allparents ps))+++getClassModuleBase :: Class -> String +getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> class_name ++++-- | Daughter map not including itself+mkDaughterMap :: [Class] -> DaughterMap +mkDaughterMap = foldl mkDaughterMapWorker M.empty + where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)+ in foldl (addmeToYourDaughterList c) m ps + addmeToYourDaughterList c m p = let f Nothing = Just [c]+ f (Just cs) = Just (c:cs) + in M.alter f p m++++-- | Daughter Map including itself as a daughter+mkDaughterSelfMap :: [Class] -> DaughterMap+mkDaughterSelfMap = foldl worker M.empty + where worker m c = let ps = map getClassModuleBase (c:class_allparents c)+ in foldl (addToList c) m ps + addToList c m p = let f Nothing = Just [c]+ 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'+++typeclassName :: Class -> String+typeclassName c = 'I' : class_name c++typeclassNameFromStr :: String -> String +typeclassNameFromStr = ('I':)++hsClassName :: Class -> (String, String) -- ^ High-level, 'Raw'-level+hsClassName c = + let cname = class_name c+ in (cname, "Raw" ++ cname) ++existConstructorName :: Class -> String +existConstructorName c = 'E' : class_name c++hsFuncTyp :: Class -> Function -> String+hsFuncTyp c f = let args = genericFuncArgs f + ret = genericFuncRet f + in selfstr ++ " -> " ++ concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret + + where (_hcname,rcname) = hsClassName c+ selfstr = "(Ptr " ++ rcname ++ ")" ++ hsargtype (CT ctype _) = hsCTypeName ctype+ hsargtype (CPT x _) = hsCppTypeName x + hsargtype SelfType = selfstr + hsargtype _ = error "undefined hsargtype"+ + hsrettype Void = "IO ()"+ hsrettype SelfType = "IO " ++ selfstr+ hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype+ hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x + +hsFuncTypNoSelf :: Class -> Function -> String+hsFuncTypNoSelf c f = let args = genericFuncArgs f + ret = genericFuncRet f + in intercalateWith connArrow id $ map (hsargtype . fst) args ++ [hsrettype ret] + + where (_hcname,rcname) = hsClassName c+ selfstr = "(Ptr " ++ rcname ++ ")" ++ hsargtype (CT ctype _) = hsCTypeName ctype+ hsargtype (CPT x _) = hsCppTypeName x + hsargtype SelfType = selfstr+ hsargtype _ = error "undefined hsargtype"+ + hsrettype Void = "IO ()"+ hsrettype SelfType = "IO " ++ selfstr+ hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype+ hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x +++hscFuncName :: Class -> Function -> String +hscFuncName c f = "c_" ++ toLowers (class_name c) ++ "_" ++ toLowers (aliasedFuncName c f)+ +hsFuncName :: Class -> Function -> String +hsFuncName c f = let (x:xs) = aliasedFuncName c f + 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 _ _ _) = + let len = length (genericFuncArgs func) + in if len > 0+ then "xform" ++ show (len - 1)+ else "xformnull" +hsFuncXformer func = let len = length (genericFuncArgs func) + in "xform" ++ show len+++genericFuncRet :: Function -> Types +genericFuncRet f = + case f of + Constructor _ -> self_ + Virtual t _ _ -> t + NonVirtual t _ _ -> t+ Static t _ _ -> t+ AliasVirtual t _ _ _ -> t+ Destructor -> void_++genericFuncArgs :: Function -> Args +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 ++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++constructorName :: Class -> String+constructorName c = "new" ++ (class_name c) + +nonvirtualName :: Class -> String -> String+nonvirtualName c str = firstLower (class_name c) ++ str ++destructorName :: String +destructorName = "delete"
+ lib/FFICXX/Generate/Type/Module.hs view
@@ -0,0 +1,22 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Type.Module+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Type.Module where++data Module = Module { module_name :: String + , module_exports :: [String] + } ++mkModuleExports :: Module -> String+mkModuleExports _mod = "" ++-- "\n ( " ++ intercalate "\n , " (module_exports mod) ++ ")"
+ lib/FFICXX/Generate/Type/PackageInterface.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Type.PackageInterface+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Type.PackageInterface where ++import Data.Hashable+import qualified Data.HashMap.Strict as HM++newtype PackageName = PkgName String deriving (Hashable, Show, Eq, Ord)+newtype ClassName = ClsName String deriving (Hashable, Show, Eq, Ord)+newtype HeaderName = HdrName String deriving (Hashable, Show, Eq, Ord)++type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName ++newtype TypeMacro = TypMcro { unTypMcro :: String } + deriving (Show,Eq,Ord)
+ lib/FFICXX/Generate/Util.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Util+-- Copyright : (c) 2011-2013 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------+++module FFICXX.Generate.Util where+++-- +import Data.Char +import Data.List+import Data.List.Split +import qualified Text.StringTemplate as ST+-- +-- import FFICXX.Generate.Type.CType +-- ++moduleDirFile :: String -> (String,String)+moduleDirFile mname = + let splitted = splitOn "." mname+ moddir = intercalate "/" (init splitted )+ modfile = (last splitted) ++ ".hs" + in (moddir, modfile)++hline :: IO ()+hline = putStrLn "--------------------------------------------------------"++toUppers :: String -> String+toUppers = map toUpper++toLowers :: String -> String +toLowers = map toLower+++firstLower :: String -> String +firstLower [] = [] +firstLower (x:xs) = (toLower x) : xs ++conn :: String -> String -> String -> String +conn st x y = x ++ st ++ y ++connspace :: String -> String -> String+connspace = conn " " ++conncomma :: String -> String -> String+conncomma = conn ", " ++connBSlash :: String -> String -> String +connBSlash = conn "\\\n"++connSemicolonBSlash :: String -> String -> String+connSemicolonBSlash = conn "; \\\n"++connRet :: String -> String -> String+connRet = conn "\n"++connRet2 :: String -> String -> String +connRet2 = conn "\n\n"++connArrow :: String -> String -> String +connArrow = conn " -> " ++intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String+intercalateWith f mapper x + | not (null x) = foldl1 f (map mapper x)+-- (foldl1 (\x1 y -> x1 `f` y) . (map mapper)) x + | otherwise = "" +++intercalateWithM :: (Monad m) => (String -> String -> String) -> (a->m String) -> [a] -> m String +intercalateWithM f mapper x + | not (null x) = do ms <- mapM mapper x+ return (foldl1 f ms)+ | otherwise = return "" ++-- intercalateM :: (Monad m) => String -> [String] -> m String +-- intercalateM str = return . foldl1 (\x y-> x ++ str ++ y)+++ +render :: String -> [(String,String)] -> String +render tmpl attribs = (ST.render . ST.setManyAttrib attribs . ST.newSTMP) tmpl + -- flip render1++renderTemplateGroup :: (ST.ToSElem a) => ST.STGroup String -> [(String,a)] + -> [Char] -> String +renderTemplateGroup gr attrs tmpl = + maybe ("template not found: " ++ tmpl)+ (ST.toString . setManyAttribSafer attrs) + (ST.getStringTemplate tmpl gr)+ +setManyAttribSafer :: (ST.Stringable b, ST.ToSElem a) => + [(String, a)] + -> ST.StringTemplate b + -> ST.StringTemplate b+setManyAttribSafer attrs st = + let mbFoundbadattr = find badTmplVarName . map fst $ attrs + in maybe (ST.setManyAttrib attrs st) + (\mbA -> ST.newSTMP . ("setManyAttribSafer, bad template atr: "++) + $ mbA)+ mbFoundbadattr + where badTmplVarName :: String -> Bool + badTmplVarName t = not . null . filter (not . isAlpha) $ t ++
+ lib/FFICXX/Paths_fficxx.hs view
@@ -0,0 +1,6 @@+module FFICXX.Paths_fficxx (+ module Paths_fficxx+ ) where++import Paths_fficxx+
+ template/Cast.hs.st view
@@ -0,0 +1,14 @@+{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies, + MultiParamTypeClasses, OverlappingInstances, IncoherentInstances #-}++$castHeader$++import Foreign.Ptr+import Foreign.ForeignPtr (castForeignPtr, newForeignPtr_)+import Foreign.ForeignPtr.Unsafe+import FFICXX.Runtime.Cast+import System.IO.Unsafe++$castImport$++$castBody$
+ template/Class.hs-boot.st view
@@ -0,0 +1,3 @@+module $moduleName$ where++$hsBootBody$
+ template/Existential.hs.st view
@@ -0,0 +1,28 @@+{-# LANGUAGE TypeFamilies, GADTs, ExistentialQuantification, EmptyDataDecls #-}++-- module HROOT.Class.Existential where++$existHeader$+++--import Foreign.C +import Foreign.ForeignPtr+--import Foreign.Marshal.Array+import HROOT.TypeCast+import HROOT.Class.TClass.RawType+import HROOT.Class.TClass.Interface+import HROOT.Class.TClass.Cast+import HROOT.Class.TClass.Implementation+import HROOT.Class.TObject.RawType+import HROOT.Class.TObject.Interface+import HROOT.Class.TObject.Cast+import HROOT.Class.TObject.Implementation++$existImport$++-- import HROOT.Class.$modname$.Interface+-- import HROOT.Class.$modname$.Implementation ()++$existEachBody$++
+ template/ExistentialEach.hs.st view
@@ -0,0 +1,19 @@+instance GADTTypeable $mother$ where+ data GADTType $mother$ a where +$GADTbody$+ GADT$mother$Bottom :: GADTType $mother$ BottomType+ data EGADTType $mother$ = forall a. EGADT$mother$ (GADTType $mother$ a)++cast$mother$ :: Exist $mother$ -> IO (EGADTType $mother$)+cast$mother$ eobj = do + let obj = $mother$ (get_fptr eobj)+ tclass <- isA obj + cname <- getName tclass+ case cname of +$castbody$+ _ -> return . EGADT$mother$ \$ GADT$mother$Bottom+++++
+ template/FFI.hsc.st view
@@ -0,0 +1,19 @@+{-# LANGUAGE ForeignFunctionInterface #-}++-- module HROOT.Class.FFI where++$ffiHeader$++import Foreign.C +import Foreign.Ptr++-- import HROOT.Class.Interface++-- #include "$headerFileName$"++$ffiImport$++$cppInclude$++$hsFunctionBody$+
+ template/Implementation.hs.st view
@@ -0,0 +1,17 @@+{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, + FlexibleInstances, TypeSynonymInstances, EmptyDataDecls, + OverlappingInstances, IncoherentInstances #-}++$implHeader$++import FFICXX.Runtime.Cast++$implImport$++import Data.Word+import Foreign.ForeignPtr++import System.IO.Unsafe+++$implBody$
+ template/Interface.hs.st view
@@ -0,0 +1,15 @@+{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, + FlexibleInstances, TypeSynonymInstances, + EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-}++-- module HROOT.Class.Interface where++$ifaceHeader$++import Data.Word+import Foreign.ForeignPtr+import FFICXX.Runtime.Cast++$ifaceImport$++$ifaceBody$
+ template/Module.h.st view
@@ -0,0 +1,18 @@+#ifdef __cplusplus+extern "C" { +#endif ++#ifndef $typemacro$+#define $typemacro$++#include "$cprefix$Type.h"++$declarationheader$++$declarationbody$++#endif // $typemacro$++#ifdef __cplusplus+}+#endif
+ template/Pkg.cabal.st view
@@ -0,0 +1,40 @@+Name: $pkgname$+Version: $version$+Synopsis: $synopsis$+Description: $description$+Homepage: $homepage$+$license$+Author: $author$+Maintainer: $maintainer$+Category: $category$+Tested-with: GHC >= 7.0+Build-Type: $buildtype$+cabal-version: >=1.10+Extra-source-files: +$cabalIndentation$CHANGES+$cabalIndentation$Config.hs+$csrcFiles$++$sourcerepository$++Library+ default-language: Haskell2010+ hs-source-dirs: src+ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports+ ghc-prof-options: -caf-all -auto-all+ Build-Depends: base>4 && < 5, fficxx-runtime >= 0.0.999 $deps$+ Exposed-Modules:+$exposedModules$ + Other-Modules:+$otherModules$+ extra-lib-dirs: $extralibdirs$+ extra-libraries: stdc++ $extralib$+ Include-dirs: csrc $extraincludedirs$ + Install-includes: +$includeFiles$+ C-sources: +$cppFiles$++ ++
+ template/Pkg.cpp.st view
@@ -0,0 +1,42 @@+#include <MacroPatternMatch.h>++$header$++using namespace std;+$namespace$++template<class ToType, class FromType>+const ToType* to_const(const FromType* x) {+ return reinterpret_cast<const ToType*>(x);+}++template<class ToType, class FromType>+ToType* to_nonconst(FromType* x) {+ return reinterpret_cast<ToType*>(x);+}++template<class ToType, class FromType>+const ToType& to_constref(const FromType& x) {+ return reinterpret_cast<const ToType&>(x);+}++template<class ToType, class FromType>+ToType& to_nonconstref(FromType& x) {+ return reinterpret_cast<ToType&>(x);+}+++#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)++#define TYPECASTMETHOD(cname,mname,oname) \\+ IIF( CHECKPROTECT(cname,mname) ) ( \\+ (to_nonconst<oname,cname ## _t>), \\+ (to_nonconst<cname,cname ## _t>) )++$cppbody$++void dummy$modname$ ( void ) +{+ +}+
+ template/Pkg.hs.st view
@@ -0,0 +1,6 @@+module $summarymod$ (+$exportList$ +) where++$importList$+
+ template/PkgType.h.st view
@@ -0,0 +1,20 @@+#ifdef __cplusplus+extern "C" { +#endif++#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$++#ifdef __cplusplus+}+#endif
+ template/RawType.hs.st view
@@ -0,0 +1,10 @@+{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, + FlexibleInstances, TypeSynonymInstances, + EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-}++$rawtypeHeader$++import Foreign.ForeignPtr+import FFICXX.Runtime.Cast ++$rawtypeBody$
+ template/classdef.cpp.st view
@@ -0,0 +1,3 @@+#undef ROOT_$classname$_DEFINITION+#define ROOT_$classname$_DEFINITION(Type) \\+$funcdef$
+ template/declbody.h.st view
@@ -0,0 +1,4 @@+#undef ROOT_$classname$_DECLARATION +#define ROOT_$classname$_DECLARATION \\+ $funcdecl$+
+ template/funcdecl.h.st view
@@ -0,0 +1,1 @@+$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ )
+ template/function.cpp.st view
@@ -0,0 +1,4 @@+$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ ) \\+{ \\+ $funcbody$ \\+}
+ template/functionbody.cpp.st view
@@ -0,0 +1,1 @@+to_nonconst<Type,Type ## _t>(p) -> $funcname$ ( $args$ ) ;
+ template/module.hs.st view
@@ -0,0 +1,7 @@+module $moduleName$+ (+$exportList$ + ) where++$importList$+