diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -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 +> -- } diff --git a/fficxx.cabal b/fficxx.cabal new file mode 100644 --- /dev/null +++ b/fficxx.cabal @@ -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 +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 + diff --git a/lib/FFICXX/Generate/Code/Cabal.hs b/lib/FFICXX/Generate/Code/Cabal.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/Cabal.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Code.Cabal +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) +-} diff --git a/lib/FFICXX/Generate/Code/Cpp.hs b/lib/FFICXX/Generate/Code/Cpp.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/Cpp.hs @@ -0,0 +1,195 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Code.Cpp +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + diff --git a/lib/FFICXX/Generate/Code/Dependency.hs b/lib/FFICXX/Generate/Code/Dependency.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/Dependency.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Code.Dependency +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) diff --git a/lib/FFICXX/Generate/Code/HsFFI.hs b/lib/FFICXX/Generate/Code/HsFFI.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/HsFFI.hs @@ -0,0 +1,60 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Code.HsFFI +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) ] -} + diff --git a/lib/FFICXX/Generate/Code/HsFrontEnd.hs b/lib/FFICXX/Generate/Code/HsFrontEnd.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/HsFrontEnd.hs @@ -0,0 +1,581 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Code.Cpp +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + + + diff --git a/lib/FFICXX/Generate/Code/MethodDef.hs b/lib/FFICXX/Generate/Code/MethodDef.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/MethodDef.hs @@ -0,0 +1,93 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Code.MethodDef +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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(newp);" + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | isDeleteFunc func = + let declstr = funcToDecl c func + returnstr = "delete (to_nonconst(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 *)" ++ 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(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 *)" ++ 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) + + + + + + diff --git a/lib/FFICXX/Generate/Config.hs b/lib/FFICXX/Generate/Config.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Config.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Config +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + + +module FFICXX.Generate.Config where + +data FFICXXConfig = FFICXXConfig { + fficxxconfig_scriptBaseDir :: FilePath, + fficxxconfig_workingDir :: FilePath, + fficxxconfig_installBaseDir :: FilePath +} deriving Show + diff --git a/lib/FFICXX/Generate/Generator/ContentMaker.hs b/lib/FFICXX/Generate/Generator/ContentMaker.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Generator/ContentMaker.hs @@ -0,0 +1,408 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Generator.ContentMaker +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + diff --git a/lib/FFICXX/Generate/Generator/Driver.hs b/lib/FFICXX/Generate/Generator/Driver.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Generator/Driver.hs @@ -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 () diff --git a/lib/FFICXX/Generate/QQ/Verbatim.hs b/lib/FFICXX/Generate/QQ/Verbatim.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/QQ/Verbatim.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.QQ.Verbatim +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + } + diff --git a/lib/FFICXX/Generate/Type/Annotate.hs b/lib/FFICXX/Generate/Type/Annotate.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Type/Annotate.hs @@ -0,0 +1,23 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Type.Annotate +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + + diff --git a/lib/FFICXX/Generate/Type/Class.hs b/lib/FFICXX/Generate/Type/Class.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Type/Class.hs @@ -0,0 +1,514 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Type.Class +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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" diff --git a/lib/FFICXX/Generate/Type/Module.hs b/lib/FFICXX/Generate/Type/Module.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Type/Module.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Type.Module +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) ++ ")" diff --git a/lib/FFICXX/Generate/Type/PackageInterface.hs b/lib/FFICXX/Generate/Type/PackageInterface.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Type/PackageInterface.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Type.PackageInterface +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) diff --git a/lib/FFICXX/Generate/Util.hs b/lib/FFICXX/Generate/Util.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Util.hs @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Util +-- Copyright : (c) 2011-2013 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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 + + diff --git a/lib/FFICXX/Paths_fficxx.hs b/lib/FFICXX/Paths_fficxx.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Paths_fficxx.hs @@ -0,0 +1,6 @@ +module FFICXX.Paths_fficxx ( + module Paths_fficxx + ) where + +import Paths_fficxx + diff --git a/template/Cast.hs.st b/template/Cast.hs.st new file mode 100644 --- /dev/null +++ b/template/Cast.hs.st @@ -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$ diff --git a/template/Class.hs-boot.st b/template/Class.hs-boot.st new file mode 100644 --- /dev/null +++ b/template/Class.hs-boot.st @@ -0,0 +1,3 @@ +module $moduleName$ where + +$hsBootBody$ diff --git a/template/Existential.hs.st b/template/Existential.hs.st new file mode 100644 --- /dev/null +++ b/template/Existential.hs.st @@ -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$ + + diff --git a/template/ExistentialEach.hs.st b/template/ExistentialEach.hs.st new file mode 100644 --- /dev/null +++ b/template/ExistentialEach.hs.st @@ -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 + + + + + diff --git a/template/FFI.hsc.st b/template/FFI.hsc.st new file mode 100644 --- /dev/null +++ b/template/FFI.hsc.st @@ -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$ + diff --git a/template/Implementation.hs.st b/template/Implementation.hs.st new file mode 100644 --- /dev/null +++ b/template/Implementation.hs.st @@ -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$ diff --git a/template/Interface.hs.st b/template/Interface.hs.st new file mode 100644 --- /dev/null +++ b/template/Interface.hs.st @@ -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$ diff --git a/template/Module.h.st b/template/Module.h.st new file mode 100644 --- /dev/null +++ b/template/Module.h.st @@ -0,0 +1,18 @@ +#ifdef __cplusplus +extern "C" { +#endif + +#ifndef $typemacro$ +#define $typemacro$ + +#include "$cprefix$Type.h" + +$declarationheader$ + +$declarationbody$ + +#endif // $typemacro$ + +#ifdef __cplusplus +} +#endif diff --git a/template/Pkg.cabal.st b/template/Pkg.cabal.st new file mode 100644 --- /dev/null +++ b/template/Pkg.cabal.st @@ -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$ + + + + diff --git a/template/Pkg.cpp.st b/template/Pkg.cpp.st new file mode 100644 --- /dev/null +++ b/template/Pkg.cpp.st @@ -0,0 +1,42 @@ +#include + +$header$ + +using namespace std; +$namespace$ + +template +const ToType* to_const(const FromType* x) { + return reinterpret_cast(x); +} + +template +ToType* to_nonconst(FromType* x) { + return reinterpret_cast(x); +} + +template +const ToType& to_constref(const FromType& x) { + return reinterpret_cast(x); +} + +template +ToType& to_nonconstref(FromType& x) { + return reinterpret_cast(x); +} + + +#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED) + +#define TYPECASTMETHOD(cname,mname,oname) \\ + IIF( CHECKPROTECT(cname,mname) ) ( \\ + (to_nonconst), \\ + (to_nonconst) ) + +$cppbody$ + +void dummy$modname$ ( void ) +{ + +} + diff --git a/template/Pkg.hs.st b/template/Pkg.hs.st new file mode 100644 --- /dev/null +++ b/template/Pkg.hs.st @@ -0,0 +1,6 @@ +module $summarymod$ ( +$exportList$ +) where + +$importList$ + diff --git a/template/PkgType.h.st b/template/PkgType.h.st new file mode 100644 --- /dev/null +++ b/template/PkgType.h.st @@ -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 diff --git a/template/RawType.hs.st b/template/RawType.hs.st new file mode 100644 --- /dev/null +++ b/template/RawType.hs.st @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, + FlexibleInstances, TypeSynonymInstances, + EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-} + +$rawtypeHeader$ + +import Foreign.ForeignPtr +import FFICXX.Runtime.Cast + +$rawtypeBody$ diff --git a/template/classdef.cpp.st b/template/classdef.cpp.st new file mode 100644 --- /dev/null +++ b/template/classdef.cpp.st @@ -0,0 +1,3 @@ +#undef ROOT_$classname$_DEFINITION +#define ROOT_$classname$_DEFINITION(Type) \\ +$funcdef$ diff --git a/template/declbody.h.st b/template/declbody.h.st new file mode 100644 --- /dev/null +++ b/template/declbody.h.st @@ -0,0 +1,4 @@ +#undef ROOT_$classname$_DECLARATION +#define ROOT_$classname$_DECLARATION \\ + $funcdecl$ + diff --git a/template/funcdecl.h.st b/template/funcdecl.h.st new file mode 100644 --- /dev/null +++ b/template/funcdecl.h.st @@ -0,0 +1,1 @@ +$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ ) diff --git a/template/function.cpp.st b/template/function.cpp.st new file mode 100644 --- /dev/null +++ b/template/function.cpp.st @@ -0,0 +1,4 @@ +$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ ) \\ +{ \\ + $funcbody$ \\ +} diff --git a/template/functionbody.cpp.st b/template/functionbody.cpp.st new file mode 100644 --- /dev/null +++ b/template/functionbody.cpp.st @@ -0,0 +1,1 @@ +to_nonconst(p) -> $funcname$ ( $args$ ) ; diff --git a/template/module.hs.st b/template/module.hs.st new file mode 100644 --- /dev/null +++ b/template/module.hs.st @@ -0,0 +1,7 @@ +module $moduleName$ + ( +$exportList$ + ) where + +$importList$ +