diff --git a/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -1,7 +1,7 @@ Name: fficxx -Version: 0.2 +Version: 0.2.1 Synopsis: automatic C++ binding generation -Description: automatic C++ binding generation +Description: automatic C++ binding generation License: BSD3 License-file: LICENSE Author: Ian-Woo Kim @@ -15,14 +15,13 @@ template/*.hs-boot.st template/*.cpp.st template/Pkg.cabal.st - sample/cxxlib/build.sh sample/cxxlib/include/*.h sample/cxxlib/src/*.cpp - sample/cxxlib/src/Makefile + sample/cxxlib/Makefile sample/mysample-generator/MySampleGen.hs sample/mysample-generator/use_mysample.hs sample/snappy-generator/SnappyGen.hs - + sample/snappy-generator/testSnappy.hs Source-repository head type: git @@ -32,27 +31,28 @@ 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, + Build-Depends: base == 4.*, + data-default, + mtl>2, + containers, + filepath>1, + directory, + HStringTemplate, split, process, - transformers >= 0.3, - template-haskell, + transformers >= 0.3, + template-haskell, hashable, unordered-containers, lens > 3, - either, - errors, + either, + errors < 2.0, bytestring, - pureMD5, + pureMD5, Cabal - Exposed-Modules: - FFICXX.Generate.Builder + Exposed-Modules: + FFICXX.Generate.Builder FFICXX.Generate.Type.Class FFICXX.Generate.Type.Module FFICXX.Generate.Type.PackageInterface diff --git a/lib/FFICXX/Generate/Builder.hs b/lib/FFICXX/Generate/Builder.hs --- a/lib/FFICXX/Generate/Builder.hs +++ b/lib/FFICXX/Generate/Builder.hs @@ -2,8 +2,8 @@ ----------------------------------------------------------------------------- -- | --- Module : FFICXX.Generate.Builder --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Module : FFICXX.Generate.Builder +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -12,12 +12,15 @@ -- ----------------------------------------------------------------------------- -module FFICXX.Generate.Builder where +module FFICXX.Generate.Builder where -import Data.Char (toUpper) -import Data.Monoid (mempty) -import System.FilePath (()) -import System.Directory (getCurrentDirectory) +import Data.Char (toUpper) +import qualified Data.HashMap.Strict as HM +import Data.List (intercalate) +import Data.Monoid (mempty) +import System.FilePath ((), (<.>)) +import System.Directory (getCurrentDirectory) +import System.Process (readProcess) import Text.StringTemplate hiding (render) -- import FFICXX.Generate.Code.Cabal @@ -27,123 +30,154 @@ import FFICXX.Generate.Code.Cpp import FFICXX.Generate.Code.Dependency import FFICXX.Generate.Config -import FFICXX.Generate.Generator.ContentMaker +import FFICXX.Generate.Generator.ContentMaker import FFICXX.Generate.Generator.Driver import FFICXX.Generate.Type.Annotate -import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Class ( Cabal(..) + , CabalAttr(..) + , Class + , ClassModule + , Namespace(NS) + , TopLevelFunction + , TopLevelImportHeader + ) import FFICXX.Generate.Type.PackageInterface import FFICXX.Generate.Util --- +-- import qualified FFICXX.Paths_fficxx as F --- | -cabalTemplate :: String +-- | +cabalTemplate :: String cabalTemplate = "Pkg.cabal" --- | +-- | mkCabalFile :: FFICXXConfig - -> STGroup String - -> Cabal + -> STGroup String + -> (Cabal, CabalAttr) + -> String -> (TopLevelImportHeader,[ClassModule]) - -> FilePath - -> IO () -mkCabalFile config templates cabal (tih,classmodules) cabalfile = do - cpath <- getCurrentDirectory - - let str = renderTemplateGroup - templates - [ ("pkgname", cabal_pkgname cabal) - , ("version", "0.0") - , ("license", "" ) - , ("buildtype", "Simple") - , ("deps", "" ) - , ("csrcFiles", genCsrcFiles (tih,classmodules)) - , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) classmodules) - , ("cppFiles", genCppFiles (tih,classmodules)) - , ("exposedModules", genExposedModules (cabal_pkgname cabal) classmodules) - , ("otherModules", genOtherModules classmodules) - , ("extralibdirs", "" ) - , ("extraincludedirs", "" ) - , ("extralib", ", snappy") - , ("cabalIndentation", cabalIndentation) - ] - cabalTemplate + -> [String] -- ^ extra libs + -> FilePath + -> IO () +mkCabalFile config + templates + (cabal, cabalattr) + summarymodule + (tih,classmodules) + extralibs + cabalfile + = do + cpath <- getCurrentDirectory + + let str = renderTemplateGroup + templates + ( [ ("licenseField", "license: " ++ license) + | Just license <- [cabalattr_license cabalattr] ] ++ + [ ("licenseFileField", "license-file: " ++ licensefile) + | Just licensefile <- [cabalattr_licensefile cabalattr] ] ++ + [ ("pkgname", cabal_pkgname cabal) + , ("version", "0.0") + , ("buildtype", "Simple") + , ("deps", "") + , ("csrcFiles", genCsrcFiles (tih,classmodules)) + , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) classmodules) + , ("cppFiles", genCppFiles (tih,classmodules)) + , ("exposedModules", genExposedModules summarymodule classmodules) + , ("otherModules", genOtherModules classmodules) + , ("extralibdirs", intercalate ", " $ cabalattr_extralibdirs cabalattr) + , ("extraincludedirs", intercalate ", " $ cabalattr_extraincludedirs cabalattr) + , ("extraLibraries", concatMap (", " ++) extralibs) + , ("cabalIndentation", cabalIndentation) + ] + ) + cabalTemplate writeFile cabalfile str -macrofy :: String -> String +macrofy :: String -> String macrofy = map ((\x->if x=='-' then '_' else x) . toUpper) -simpleBuilder :: (Cabal,[Class],[TopLevelFunction]) -> IO () -simpleBuilder (cabal,myclasses, toplevelfunctions) = do - putStrLn "generate snappy" - cwd <- getCurrentDirectory - - let cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd +simpleBuilder :: String -> [(String,([Namespace],[HeaderName]))] + -> (Cabal, CabalAttr, [Class], [TopLevelFunction]) + -> [String] -- ^ extra libs + -> IO () +simpleBuilder summarymodule m (cabal, cabalattr, myclasses, toplevelfunctions) extralibs = do + let pkgname = cabal_pkgname cabal + putStrLn ("generating " ++ pkgname) + cwd <- getCurrentDirectory + let cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd , fficxxconfig_workingDir = cwd "working" - , fficxxconfig_installBaseDir = cwd (cabal_pkgname cabal) - } + , fficxxconfig_installBaseDir = cwd pkgname + } workingDir = fficxxconfig_workingDir cfg - installDir = fficxxconfig_installBaseDir cfg - pkgname = "Snappy" - (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH - ("Snappy", (const ([NS "snappy"],["snappy-sinksource.h","snappy.h"]))) + installDir = fficxxconfig_installBaseDir cfg + + (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH + (pkgname, mkClassNSHeaderFromMap (HM.fromList m)) (myclasses, toplevelfunctions) - hsbootlst = mkHSBOOTCandidateList mods - cglobal = mkGlobal myclasses - summarymodule = "Snappy" - cabalFileName = "Snappy.cabal" + hsbootlst = mkHSBOOTCandidateList mods + cglobal = mkGlobal myclasses + -- summarymodule = -- pkgname -- "Snappy" + cabalFileName = pkgname <.> "cabal" -- "Snappy.cabal" templateDir <- F.getDataDir >>= return . ( "template") - (templates :: STGroup String) <- directoryGroup templateDir - -- + (templates :: STGroup String) <- directoryGroup templateDir + -- notExistThenCreate workingDir - notExistThenCreate installDir - notExistThenCreate (installDir "src") + notExistThenCreate installDir + notExistThenCreate (installDir "src") notExistThenCreate (installDir "csrc") - -- - putStrLn "cabal file generation" - mkCabalFile cfg templates cabal (tih,mods) (workingDir cabalFileName) - -- + -- + putStrLn "cabal file generation" + mkCabalFile cfg templates (cabal, cabalattr) summarymodule (tih,mods) extralibs (workingDir cabalFileName) + -- putStrLn "header file generation" let typmacro = TypMcro ("__" ++ macrofy (cabal_pkgname cabal) ++ "__") {- "__SNAPPY__" -} writeTypeDeclHeaders templates workingDir typmacro pkgname cihs mapM_ (writeDeclHeaders templates workingDir typmacro pkgname) cihs writeTopLevelFunctionHeaders templates workingDir typmacro pkgname tih - -- - putStrLn "cpp file generation" + -- + putStrLn "cpp file generation" mapM_ (writeCppDef templates workingDir) cihs writeTopLevelFunctionCppDef templates workingDir typmacro pkgname tih - -- - putStrLn "RawType.hs file generation" - mapM_ (writeRawTypeHs templates workingDir) mods - -- + -- + putStrLn "RawType.hs file generation" + mapM_ (writeRawTypeHs templates workingDir) mods + -- putStrLn "FFI.hsc file generation" mapM_ (writeFFIHsc templates workingDir) mods - -- - putStrLn "Interface.hs file generation" + -- + putStrLn "Interface.hs file generation" mapM_ (writeInterfaceHs mempty templates workingDir) mods - -- + -- putStrLn "Cast.hs file generation" mapM_ (writeCastHs templates workingDir) mods - -- + -- putStrLn "Implementation.hs file generation" mapM_ (writeImplementationHs mempty templates workingDir) mods - -- - putStrLn "hs-boot file generation" - mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst - -- - putStrLn "module file generation" + -- + putStrLn "hs-boot file generation" + mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst + -- + putStrLn "module file generation" mapM_ (writeModuleHs templates workingDir) mods - -- + -- putStrLn "summary module generation generation" writePkgHs summarymodule templates workingDir mods tih - -- + -- putStrLn "copying" - copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) + touch (workingDir "LICENSE") + copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) + copyFileWithMD5Check (workingDir "LICENSE") (installDir "LICENSE") -- copyPredefined templateDir (srcDir ibase) pkgname + copyCppFiles workingDir (csrcDir installDir) pkgname (tih,cihs) - mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods + mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods +-- | some dirty hack. later, we will do it with more proper approcah. +touch :: FilePath -> IO () +touch fp = do + readProcess "touch" [fp] "" + return () diff --git a/lib/FFICXX/Generate/Code/Cabal.hs b/lib/FFICXX/Generate/Code/Cabal.hs --- a/lib/FFICXX/Generate/Code/Cabal.hs +++ b/lib/FFICXX/Generate/Code/Cabal.hs @@ -34,11 +34,3 @@ -- | 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 --- a/lib/FFICXX/Generate/Code/Cpp.hs +++ b/lib/FFICXX/Generate/Code/Cpp.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cpp --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -19,10 +19,10 @@ 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 +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.PackageInterface -- Class Declaration and Definition @@ -142,12 +142,13 @@ genAllCppHeaderInclude :: ClassImportHeader -> String genAllCppHeaderInclude header = intercalateWith connRet (\x->"#include \""++x++"\"") $ - cihIncludedHPkgHeadersInCPP header - ++ cihIncludedCPkgHeaders header + map unHdrName (cihIncludedHPkgHeadersInCPP header + ++ cihIncludedCPkgHeaders header) + genModuleIncludeHeader :: [ClassImportHeader] -> String genModuleIncludeHeader headers = - let strlst = map ((\x->"#include \""++x++"\"") . cihSelfHeader) headers + let strlst = map ((\x->"#include \""++x++"\"") . unHdrName . cihSelfHeader) headers in intercalate "\n" strlst ---- @@ -162,7 +163,7 @@ y <- cmCIH x return (cihSelfHeader y) selfheaders = nub selfheaders' - includeFileStrs = map (\x->indent++x) selfheaders + includeFileStrs = map ((indent++).unHdrName) selfheaders in unlines ((indent++pkgname++"Type.h") : includeFileStrs) genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> String @@ -180,8 +181,8 @@ selfcpp = nub selfcpp' tlh = tihHeaderFileName tih <.> "h" tlcpp = tihHeaderFileName tih <.> "cpp" - includeFileStrsWithCsrc = map (\x->indent++"csrc"x) - (if (null.tihFuncs) tih then selfheaders else tlh:selfheaders) + includeFileStrsWithCsrc = map (\x->indent++"csrc" x) + (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders)) cppFilesWithCsrc = map (\x->indent++"csrc"x) (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) @@ -229,6 +230,7 @@ returnstr = case toplevelfunc_ret of Void -> callstr ++ ";" SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" + (CT (CRef _) _) -> "return ((*)"++callstr++");" (CT _ctyp _isconst) -> "return "++callstr++";" (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str ++">(("++str++"*)"++callstr++");" @@ -248,6 +250,7 @@ Void -> callstr ++ ";" SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" (CT _ctyp _isconst) -> "return "++callstr++";" + (CT (CRef _) _) -> "return ((*)"++callstr++");" (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str ++">(("++str++"*)"++callstr++");" where str = class_name c' diff --git a/lib/FFICXX/Generate/Code/Dependency.hs b/lib/FFICXX/Generate/Code/Dependency.hs --- a/lib/FFICXX/Generate/Code/Dependency.hs +++ b/lib/FFICXX/Generate/Code/Dependency.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Dependency --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -14,20 +14,21 @@ module FFICXX.Generate.Code.Dependency where -import Control.Applicative -import Data.Function (on) -import Data.List -import Data.Maybe -import System.FilePath --- -import FFICXX.Generate.Type.Class +import Control.Applicative +import Data.Function (on) +import Data.List +import Data.Maybe +import qualified Data.HashMap.Strict as HM +import System.FilePath -- --- import Debug.Trace +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.PackageInterface + -- | -mkPkgHeaderFileName ::Class -> String +mkPkgHeaderFileName ::Class -> HeaderName mkPkgHeaderFileName c = - (cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "h" + HdrName ((cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "h") -- | mkPkgCppFileName ::Class -> String @@ -35,22 +36,22 @@ (cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "cpp" -- | -mkPkgIncludeHeadersInH :: Class -> [String] +mkPkgIncludeHeadersInH :: Class -> [HeaderName] 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 + in map mkPkgHeaderFileName (class_allparents c) ++ map HdrName extheaders -- | -mkPkgIncludeHeadersInCPP :: Class -> [String] +mkPkgIncludeHeadersInCPP :: Class -> [HeaderName] mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . mkModuleDepCpp -- | -mkCIH :: (Class->([Namespace],[String])) -- ^ (mk namespace and include headers) +mkCIH :: (Class->([Namespace],[HeaderName])) -- ^ (mk namespace and include headers) -> Class -> ClassImportHeader mkCIH mkNSandIncHdrs c = let r = ClassImportHeader c @@ -86,8 +87,6 @@ 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 [] @@ -149,7 +148,7 @@ in alldeps -mkClassModule :: (Class->([Namespace],[String])) +mkClassModule :: (Class->([Namespace],[HeaderName])) -> Class -> ClassModule mkClassModule mkincheaders c = @@ -168,8 +167,11 @@ highs_source = map getClassModuleBase . mkModuleDepHighSource ffis = map getClassModuleBase . mkModuleDepFFI - -mkAll_ClassModules_CIH_TIH :: (String,Class->([Namespace],[String])) -- ^ (package name,mkIncludeHeaders) + +mkClassNSHeaderFromMap :: HM.HashMap String ([Namespace],[HeaderName]) -> Class -> ([Namespace],[HeaderName]) +mkClassNSHeaderFromMap m c = fromMaybe ([],[]) (HM.lookup (class_name c) m) + +mkAll_ClassModules_CIH_TIH :: (String,Class->([Namespace],[HeaderName])) -- ^ (package name,mkIncludeHeaders) -> ([Class],[TopLevelFunction]) -> ([ClassModule],[ClassImportHeader],TopLevelImportHeader) mkAll_ClassModules_CIH_TIH (pkgname,mkNSandIncHdrs) (cs,fs) = diff --git a/lib/FFICXX/Generate/Code/HsFFI.hs b/lib/FFICXX/Generate/Code/HsFFI.hs --- a/lib/FFICXX/Generate/Code/HsFFI.hs +++ b/lib/FFICXX/Generate/Code/HsFFI.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFFI --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -11,6 +11,7 @@ -- Portability : GHC -- ----------------------------------------------------------------------------- + module FFICXX.Generate.Code.HsFFI where import Data.Char (toLower) @@ -18,7 +19,7 @@ -- import FFICXX.Generate.Util import FFICXX.Generate.Type.Class - +import FFICXX.Generate.Type.PackageInterface genHsFFI :: ClassImportHeader -> String genHsFFI header = @@ -43,18 +44,18 @@ ffiTemplate = "foreign import ccall \"$headerfilename$ $funcname$\" $hsfuncname$ \n :: $hsargs$" -hsFFIClassFunc :: FilePath -> Class -> Function -> String +hsFFIClassFunc :: HeaderName -> Class -> Function -> String hsFFIClassFunc headerfilename c f = if isAbstractClass c then "" else if (isNewFunc f || isStaticFunc f) then render ffistub - [ ("headerfilename",headerfilename) + [ ("headerfilename",(unHdrName headerfilename)) , ("classname",class_name c) , ("funcname", aliasedFuncName c f) , ("hsfuncname",hscFuncName c f) , ("hsargs", hsFuncTypNoSelf c f) ] else render ffistub - [ ("headerfilename",headerfilename) + [ ("headerfilename",(unHdrName headerfilename)) , ("classname",class_name c) , ("funcname", aliasedFuncName c f) , ("hsfuncname",hscFuncName c f) diff --git a/lib/FFICXX/Generate/Code/HsFrontEnd.hs b/lib/FFICXX/Generate/Code/HsFrontEnd.hs --- a/lib/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/lib/FFICXX/Generate/Code/HsFrontEnd.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | --- Module : FFICXX.Generate.Code.Cpp --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Module : FFICXX.Generate.Code.HsFrontEnd +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim diff --git a/lib/FFICXX/Generate/Generator/ContentMaker.hs b/lib/FFICXX/Generate/Generator/ContentMaker.hs --- a/lib/FFICXX/Generate/Generator/ContentMaker.hs +++ b/lib/FFICXX/Generate/Generator/ContentMaker.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE GADTs #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Generator.ContentMaker --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -171,7 +173,7 @@ aclass = cihClass header typemacrostr = typemacroprefix ++ class_name aclass ++ "__" declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") $ - cihIncludedHPkgHeadersInH header + map T.unHdrName (cihIncludedHPkgHeadersInH header) declDefStr = genAllCppHeaderTmplVirtual classes `connRet2` genAllCppHeaderTmplNonVirtual classes @@ -204,7 +206,7 @@ -> String mkDefMain templates header = let classes = [cihClass header] - headerStr = genAllCppHeaderInclude header ++ "\n#include \"" ++ (cihSelfHeader header) ++ "\"" + headerStr = genAllCppHeaderInclude header ++ "\n#include \"" ++ (T.unHdrName (cihSelfHeader header)) ++ "\"" namespaceStr = (concatMap (\x->"using namespace " ++ unNamespace x ++ ";\n") . cihNamespace) header aclass = cihClass header cppBody = mkProtectedFunctionList (cihClass header) @@ -234,7 +236,7 @@ mkTopLevelFunctionHeader templates (T.TypMcro typemacroprefix) cprefix tih = let typemacrostr = typemacroprefix ++ "TOPLEVEL" ++ "__" declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") - . map cihSelfHeader . tihClassDep $ tih + . map (T.unHdrName . cihSelfHeader) . tihClassDep $ tih declBodyStr = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih) in renderTemplateGroup templates @@ -256,7 +258,7 @@ `connRet2` (intercalate "\n" (nub (map genAllCppHeaderInclude cihs))) `connRet2` - ((intercalateWith connRet (\x->"#include \""++x++"\"") . map cihSelfHeader) cihs) + ((intercalateWith connRet (\x->"#include \""++x++"\"") . map (T.unHdrName . cihSelfHeader)) cihs) allns = nubBy ((==) `on` unNamespace) (tihClassDep tih >>= cihNamespace) namespaceStr = do ns <- allns ("using namespace " ++ unNamespace ns ++ ";\n") @@ -487,5 +489,5 @@ 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 + in set (at (pkgname,T.ClsName name)) (Just header) repo diff --git a/lib/FFICXX/Generate/Generator/Driver.hs b/lib/FFICXX/Generate/Generator/Driver.hs --- a/lib/FFICXX/Generate/Generator/Driver.hs +++ b/lib/FFICXX/Generate/Generator/Driver.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Generator.Driver --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : ianwookim@gmail.com @@ -21,7 +21,6 @@ import System.IO import System.Process import Text.StringTemplate --- import Text.StringTemplate.Helpers -- import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Annotate @@ -29,8 +28,6 @@ import FFICXX.Generate.Generator.ContentMaker import FFICXX.Generate.Util - - ---- ---- Header and Cpp file ---- @@ -56,7 +53,7 @@ -> ClassImportHeader -> IO () writeDeclHeaders templates wdir typemacroprefix cprefix header = do - let fn = wdir cihSelfHeader header + let fn = wdir (unHdrName (cihSelfHeader header)) withFile fn WriteMode $ \h -> do hPutStrLn h (mkDeclHeader templates typemacroprefix cprefix header) @@ -209,7 +206,7 @@ doesFileExist (wdir tlcppfile) >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) forM_ cihs $ \header-> do - let hfile = cihSelfHeader header + let hfile = unHdrName (cihSelfHeader header) cppfile = cihSelfCpp header copyFileWithMD5Check (wdir hfile) (ddir hfile) copyFileWithMD5Check (wdir cppfile) (ddir cppfile) diff --git a/lib/FFICXX/Generate/Type/Class.hs b/lib/FFICXX/Generate/Type/Class.hs --- a/lib/FFICXX/Generate/Type/Class.hs +++ b/lib/FFICXX/Generate/Type/Class.hs @@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Class --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2013,2015 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -17,78 +17,90 @@ import Control.Applicative ((<$>),(<*>)) import Data.Char -import Data.List -import Data.Monoid +import Data.Default (Default(def)) +import Data.List +import Data.Monoid import qualified Data.Map as M -import System.FilePath --- +import System.FilePath +-- import FFICXX.Generate.Util +import FFICXX.Generate.Type.PackageInterface +-- some type aliases + +-- type HeaderFileName = String + +-- type ClassName = String + + + -- | C types -data CTypes = CTString - | CTChar - | CTInt +data CTypes = CTString + | CTChar + | CTInt | CTUInt | CTLong | CTULong - | CTDouble - | CTBool - | CTDoubleStar - | CTVoidStar - | CTIntStar - | CTCharStarStar - | CPointer CTypes - deriving Show + | CTDouble + | CTBool + | CTDoubleStar + | CTVoidStar + | CTIntStar + | CTCharStarStar + | CPointer CTypes + | CRef CTypes + deriving Show --- | C++ types -data CPPTypes = CPTClass Class - | CPTClassRef Class +-- | C++ types +data CPPTypes = CPTClass Class + | CPTClassRef Class deriving Show -- | const flag data IsConst = Const | NoConst deriving Show -data Types = Void +data Types = Void | SelfType - | CT CTypes IsConst + | CT CTypes IsConst | CPT CPPTypes IsConst deriving Show cvarToStr :: CTypes -> IsConst -> String -> String -cvarToStr ctyp isconst varname = (ctypToStr ctyp isconst) `connspace` varname +cvarToStr ctyp isconst varname = (ctypToStr ctyp isconst) `connspace` varname ctypToStr :: CTypes -> IsConst -> String -ctypToStr ctyp isconst = - let typword = case ctyp of +ctypToStr ctyp isconst = + let typword = case ctyp of CTString -> "char*" - CTChar -> "char" - CTInt -> "int" + CTChar -> "char" + CTInt -> "int" CTUInt -> "unsigned int" CTLong -> "signed long" CTULong -> "long unsigned int" - CTDouble -> "double" + CTDouble -> "double" CTBool -> "int" -- Currently available solution CTDoubleStar -> "double *" CTVoidStar -> "void*" CTIntStar -> "int*" CTCharStarStar -> "char**" - CPointer s -> ctypToStr s NoConst ++ "*" - in case isconst of - Const -> "const" `connspace` typword - NoConst -> typword + CPointer s -> ctypToStr s NoConst ++ "*" + CRef s -> ctypToStr s NoConst ++ "*" + in case isconst of + Const -> "const" `connspace` typword + NoConst -> typword -self_ :: Types +self_ :: Types self_ = SelfType cstring_ :: Types -cstring_ = CT CTString Const +cstring_ = CT CTString Const cint_ :: Types cint_ = CT CTInt Const -int_ :: Types +int_ :: Types int_ = CT CTInt NoConst uint_ :: Types @@ -106,11 +118,11 @@ clong_ :: Types clong_ = CT CTLong Const -cchar_ :: Types +cchar_ :: Types cchar_ = CT CTChar Const char_ :: Types -char_ = CT CTChar NoConst +char_ = CT CTChar NoConst short_ :: Types short_ = int_ @@ -127,39 +139,43 @@ float_ :: Types float_ = double_ -bool_ :: Types -bool_ = CT CTBool NoConst +bool_ :: Types +bool_ = CT CTBool NoConst void_ :: Types -void_ = Void +void_ = Void -voidp_ :: Types +voidp_ :: Types voidp_ = CT CTVoidStar NoConst -intp_ :: Types +intp_ :: Types intp_ = CT CTIntStar NoConst +intref_ :: Types +intref_ = CT (CRef CTInt) NoConst + + charpp_ :: Types charpp_ = CT CTCharStarStar NoConst -star_ :: CTypes -> Types +star_ :: CTypes -> Types star_ t = CT (CPointer t) NoConst -cstar_ :: CTypes -> Types -cstar_ t = CT (CPointer t) Const +cstar_ :: CTypes -> Types +cstar_ t = CT (CPointer t) Const self :: String -> (Types, String) self var = (self_, var) -voidp :: String -> (Types,String) +voidp :: String -> (Types,String) voidp var = (voidp_ , var) cstring :: String -> (Types,String) cstring var = (cstring_ , var) cint :: String -> (Types,String) -cint var = (cint_ , var) +cint var = (cint_ , var) int :: String -> (Types,String) int var = (int_ , var) @@ -180,7 +196,7 @@ culong var = (culong_ , var) cchar :: String -> (Types,String) -cchar var = (cchar_ , var) +cchar var = (cchar_ , var) char :: String -> (Types,String) char var = (char_ , var) @@ -203,17 +219,20 @@ bool :: String -> (Types,String) bool var = (bool_ , var) -intp :: String -> (Types, String) +intp :: String -> (Types, String) intp var = (intp_ , var) +intref :: String -> (Types, String) +intref var = (intref_, var) + charpp :: String -> (Types, String) charpp var = (charpp_, var) star :: CTypes -> String -> (Types, String) -star t var = (star_ t, var) +star t var = (star_ t, var) cstar :: CTypes -> String -> (Types, String) -cstar t var = (cstar_ t, var) +cstar t var = (cstar_ t, var) cppclass_ :: Class -> Types @@ -222,31 +241,31 @@ cppclass :: Class -> String -> (Types, String) cppclass c vname = ( cppclass_ c, vname) -cppclassconst :: Class -> String -> (Types, String) +cppclassconst :: Class -> String -> (Types, String) cppclassconst c vname = ( CPT (CPTClass c) Const, vname) -cppclassref_ :: Class -> Types -cppclassref_ c = CPT (CPTClassRef c) NoConst +cppclassref_ :: Class -> Types +cppclassref_ c = CPT (CPTClassRef c) NoConst -cppclassref :: Class -> String -> (Types, String) +cppclassref :: Class -> String -> (Types, String) cppclassref c vname = (cppclassref_ c, vname) -hsCTypeName :: CTypes -> String -hsCTypeName CTString = "CString" -hsCTypeName CTChar = "CChar" +hsCTypeName :: CTypes -> String +hsCTypeName CTString = "CString" +hsCTypeName CTChar = "CChar" hsCTypeName CTInt = "CInt" hsCTypeName CTUInt = "CUInt" -hsCTypeName CTLong = "CLong" -hsCTypeName CTULong = "CULong" +hsCTypeName CTLong = "CLong" +hsCTypeName CTULong = "CULong" hsCTypeName CTDouble = "CDouble" hsCTypeName CTDoubleStar = "(Ptr CDouble)" hsCTypeName CTBool = "CInt" hsCTypeName CTVoidStar = "(Ptr ())" hsCTypeName CTIntStar = "(Ptr CInt)" hsCTypeName CTCharStarStar = "(Ptr (CString))" -hsCTypeName (CPointer t) = "(Ptr " ++ hsCTypeName t ++ ")" - +hsCTypeName (CPointer t) = "(Ptr " ++ hsCTypeName t ++ ")" +hsCTypeName (CRef t) = "(Ptr " ++ hsCTypeName t ++ ")" hsCppTypeName :: CPPTypes -> String hsCppTypeName (CPTClass c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c) @@ -256,183 +275,197 @@ type Args = [(Types,String)] -data Function = Constructor { func_args :: Args - , func_alias :: Maybe String - } +data Function = Constructor { func_args :: Args + , func_alias :: Maybe String + } | Virtual { func_ret :: Types , func_name :: String - , func_args :: Args - , func_alias :: Maybe String - } - | NonVirtual { func_ret :: Types + , func_args :: Args + , func_alias :: Maybe String + } + | NonVirtual { func_ret :: Types , func_name :: String - , func_args :: Args - , func_alias :: Maybe String + , func_args :: Args + , func_alias :: Maybe String } - | Static { func_ret :: Types + | Static { func_ret :: Types , func_name :: String - , func_args :: Args - , func_alias :: Maybe String + , func_args :: Args + , func_alias :: Maybe String } - | Destructor { func_alias :: Maybe String } + | Destructor { func_alias :: Maybe String } deriving Show -data TopLevelFunction = TopLevelFunction { toplevelfunc_ret :: Types +data TopLevelFunction = TopLevelFunction { toplevelfunc_ret :: Types , toplevelfunc_name :: String - , toplevelfunc_args :: Args - , toplevelfunc_alias :: Maybe String + , toplevelfunc_args :: Args + , toplevelfunc_alias :: Maybe String } | TopLevelVariable { toplevelvar_ret :: Types - , toplevelvar_name :: String + , toplevelvar_name :: String , toplevelvar_alias :: Maybe String } - deriving Show + deriving Show -hsFrontNameForTopLevelFunction :: TopLevelFunction -> String -hsFrontNameForTopLevelFunction tfn = - let (x:xs) = case tfn of +hsFrontNameForTopLevelFunction :: TopLevelFunction -> String +hsFrontNameForTopLevelFunction tfn = + let (x:xs) = case tfn of TopLevelFunction {..} -> maybe toplevelfunc_name id toplevelfunc_alias - TopLevelVariable {..} -> maybe toplevelvar_name id toplevelvar_alias - in toLower x : xs + TopLevelVariable {..} -> maybe toplevelvar_name id toplevelvar_alias + in toLower x : xs -data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String - , tihClassDep :: [ClassImportHeader] - , tihFuncs :: [TopLevelFunction] - } +data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String + , tihClassDep :: [ClassImportHeader] + , tihFuncs :: [TopLevelFunction] + } - -isNewFunc :: Function -> Bool -isNewFunc (Constructor _ _) = True + +isNewFunc :: Function -> Bool +isNewFunc (Constructor _ _) = True isNewFunc _ = False -isDeleteFunc :: Function -> Bool -isDeleteFunc (Destructor _) = True +isDeleteFunc :: Function -> Bool +isDeleteFunc (Destructor _) = True isDeleteFunc _ = False - -isVirtualFunc :: Function -> Bool + +isVirtualFunc :: Function -> Bool isVirtualFunc (Destructor _) = True -isVirtualFunc (Virtual _ _ _ _) = True -isVirtualFunc _ = False +isVirtualFunc (Virtual _ _ _ _) = True +isVirtualFunc _ = False -isStaticFunc :: Function -> Bool +isStaticFunc :: Function -> Bool isStaticFunc (Static _ _ _ _) = True isStaticFunc _ = False -virtualFuncs :: [Function] -> [Function] -virtualFuncs = filter isVirtualFunc +virtualFuncs :: [Function] -> [Function] +virtualFuncs = filter isVirtualFunc constructorFuncs :: [Function] -> [Function] constructorFuncs = filter isNewFunc nonVirtualNotNewFuncs :: [Function] -> [Function] -nonVirtualNotNewFuncs = +nonVirtualNotNewFuncs = filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x ) -staticFuncs :: [Function] -> [Function] +staticFuncs :: [Function] -> [Function] staticFuncs = filter isStaticFunc -argToString :: (Types,String) -> String -argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname +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 +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 + 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 + where cname = class_name c argToString _ = error "undefined argToString" -argsToString :: Args -> String -argsToString args = - let args' = (SelfType, "p") : args +argsToString :: Args -> String +argsToString args = + let args' = (SelfType, "p") : args in intercalateWith conncomma argToString args' -argsToStringNoSelf :: Args -> String -argsToStringNoSelf = intercalateWith conncomma argToString +argsToStringNoSelf :: Args -> String +argsToStringNoSelf = intercalateWith conncomma argToString argToCallString :: (Types,String) -> String -argToCallString (CPT (CPTClass c) _,varname) = +argToCallString (CPT (CPTClass c) _,varname) = "to_nonconst<"++str++","++str++"_t>("++varname++")" where str = class_name c -argToCallString (CPT (CPTClassRef c) _,varname) = +argToCallString (CPT (CPTClassRef c) _,varname) = "to_nonconstref<"++str++","++str++"_t>(*"++varname++")" where str = class_name c +argToCallString (CT (CRef _) _,varname) = "(*"++ varname++ ")" argToCallString (_,varname) = varname argsToCallString :: Args -> String argsToCallString = intercalateWith conncomma argToCallString -rettypeToString :: Types -> String +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 + where str = class_name c +rettypeToString (CPT (CPTClassRef c) _) = str ++ "_p" + where str = class_name c -------- -newtype ProtectedMethod = Protected { unProtected :: [String] } - deriving (Monoid) +newtype ProtectedMethod = Protected { unProtected :: [String] } + deriving (Monoid) -data Cabal = Cabal { cabal_pkgname :: String - , cabal_cheaderprefix :: String - , cabal_moduleprefix :: String } +data Cabal = Cabal { cabal_pkgname :: String + , cabal_cheaderprefix :: String + , cabal_moduleprefix :: String + } +data CabalAttr = CabalAttr { cabalattr_license :: Maybe String + , cabalattr_licensefile :: Maybe String + , cabalattr_extraincludedirs :: [FilePath] + , cabalattr_extralibdirs :: [FilePath] + } -data Class = Class { class_cabal :: Cabal +instance Default CabalAttr where + def = CabalAttr { cabalattr_license = Nothing + , cabalattr_licensefile = Nothing + , cabalattr_extraincludedirs = [] + , cabalattr_extralibdirs = [] + } + +data Class = Class { class_cabal :: Cabal , class_name :: String - , class_parents :: [Class] + , class_parents :: [Class] , class_protected :: ProtectedMethod - , class_alias :: Maybe String - , class_funcs :: [Function] + , class_alias :: Maybe String + , class_funcs :: [Function] } - | AbstractClass { class_cabal :: Cabal + | AbstractClass { class_cabal :: Cabal , class_name :: String , class_parents :: [Class] , class_protected :: ProtectedMethod - , class_alias :: Maybe String - , class_funcs :: [Function] + , class_alias :: Maybe String + , class_funcs :: [Function] } newtype Namespace = NS { unNamespace :: String } deriving (Show) data ClassImportHeader = ClassImportHeader - { cihClass :: Class - , cihSelfHeader :: String - , cihNamespace :: [Namespace] + { cihClass :: Class + , cihSelfHeader :: HeaderName + , cihNamespace :: [Namespace] , cihSelfCpp :: String - , cihIncludedHPkgHeadersInH :: [String] - , cihIncludedHPkgHeadersInCPP :: [String] - , cihIncludedCPkgHeaders :: [String] + , cihIncludedHPkgHeadersInH :: [HeaderName] -- [String] + , cihIncludedHPkgHeadersInCPP :: [HeaderName] -- [String] + , cihIncludedCPkgHeaders :: [HeaderName] } deriving (Show) -data ClassModule = ClassModule +data ClassModule = ClassModule { cmModule :: String - , cmClass :: [Class] - , cmCIH :: [ClassImportHeader] + , cmClass :: [Class] + , cmCIH :: [ClassImportHeader] , cmImportedModulesHighNonSource :: [String] - , cmImportedModulesRaw :: [String] + , cmImportedModulesRaw :: [String] , cmImportedModulesHighSource :: [String] , cmImportedModulesForFFI :: [String] } deriving (Show) -data ClassGlobal = ClassGlobal - { cgDaughterSelfMap :: DaughterMap +data ClassGlobal = ClassGlobal + { cgDaughterSelfMap :: DaughterMap , cgDaughterMap :: DaughterMap - } + } -- | Check abstract class -isAbstractClass :: Class -> Bool -isAbstractClass (Class _ _ _ _ _ _) = False -isAbstractClass (AbstractClass _ _ _ _ _ _) = True +isAbstractClass :: Class -> Bool +isAbstractClass Class{} = False +isAbstractClass AbstractClass{} = True instance Show Class where show x = show (class_name x) @@ -443,58 +476,59 @@ instance Ord Class where compare x y = compare (class_name x) (class_name y) -type DaughterMap = M.Map String [Class] +type DaughterMap = M.Map String [Class] -class_allparents :: Class -> [Class] +class_allparents :: Class -> [Class] class_allparents c = let ps = class_parents c - in if null ps + in if null ps then [] else nub (ps ++ (concatMap class_allparents ps)) -getClassModuleBase :: Class -> String +getClassModuleBase :: Class -> String getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName) -- | Daughter map not including itself -mkDaughterMap :: [Class] -> DaughterMap -mkDaughterMap = foldl mkDaughterMapWorker M.empty +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 + in foldl (addmeToYourDaughterList c) m ps addmeToYourDaughterList c m p = let f Nothing = Just [c] - f (Just cs) = Just (c:cs) + 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 +mkDaughterSelfMap = foldl worker M.empty where worker m c = let ps = map getClassModuleBase (c:class_allparents c) - in foldl (addToList c) m ps + in foldl (addToList c) m ps addToList c m p = let f Nothing = Just [c] - f (Just cs) = Just (c:cs) + f (Just cs) = Just (c:cs) in M.alter f p m --- | +-- | ctypToHsTyp :: Maybe Class -> Types -> String -ctypToHsTyp _c Void = "()" +ctypToHsTyp _c Void = "()" ctypToHsTyp (Just c) SelfType = (fst.hsClassName) c -ctypToHsTyp Nothing SelfType = error "ctypToHsTyp : SelfType but no class " +ctypToHsTyp Nothing SelfType = error "ctypToHsTyp : SelfType but no class " ctypToHsTyp _c (CT CTString _) = "CString" -ctypToHsTyp _c (CT CTInt _) = "CInt" +ctypToHsTyp _c (CT CTInt _) = "CInt" ctypToHsTyp _c (CT CTUInt _) = "CUInt" ctypToHsTyp _c (CT CTChar _) = "CChar" ctypToHsTyp _c (CT CTLong _) = "CLong" -ctypToHsTyp _c (CT CTULong _) = "CULong" +ctypToHsTyp _c (CT CTULong _) = "CULong" ctypToHsTyp _c (CT CTDouble _) = "CDouble" ctypToHsTyp _c (CT CTBool _ ) = "CInt" ctypToHsTyp _c (CT CTDoubleStar _) = "(Ptr CDouble)" ctypToHsTyp _c (CT CTVoidStar _) = "(Ptr ())" -ctypToHsTyp _c (CT CTIntStar _) = "(Ptr CInt)" +ctypToHsTyp _c (CT CTIntStar _) = "(Ptr CInt)" ctypToHsTyp _c (CT CTCharStarStar _) = "(Ptr CString)" -ctypToHsTyp _c (CT (CPointer t) _) = hsCTypeName (CPointer t) +ctypToHsTyp _c (CT (CPointer t) _) = hsCTypeName (CPointer t) +ctypToHsTyp _c (CT (CRef t) _) = hsCTypeName (CRef t) ctypToHsTyp _c (CPT (CPTClass c') _) = class_name c' ctypToHsTyp _c (CPT (CPTClassRef c') _) = class_name c' @@ -502,118 +536,118 @@ typeclassName :: Class -> String typeclassName c = 'I' : fst (hsClassName c) -typeclassNameFromStr :: String -> String +typeclassNameFromStr :: String -> String typeclassNameFromStr = ('I':) hsClassName :: Class -> (String, String) -- ^ High-level, 'Raw'-level -hsClassName c = +hsClassName c = let cname = maybe (class_name c) id (class_alias c) - in (cname, "Raw" ++ cname) + in (cname, "Raw" ++ cname) -existConstructorName :: Class -> String -existConstructorName c = 'E' : (fst.hsClassName) c +existConstructorName :: Class -> String +existConstructorName c = 'E' : (fst.hsClassName) c -- | this is for FFI type. hsFuncTyp :: Class -> Function -> String -hsFuncTyp c f = let args = genericFuncArgs f - ret = genericFuncRet f - in selfstr ++ " -> " ++ concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret - +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 ++ ")" + selfstr = "(Ptr " ++ rcname ++ ")" hsargtype (CT ctype _) = hsCTypeName ctype - hsargtype (CPT x _) = hsCppTypeName x - hsargtype SelfType = selfstr + 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 + hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x -- | this is for FFI hsFuncTypNoSelf :: Class -> Function -> String -hsFuncTypNoSelf c f = let args = genericFuncArgs f - ret = genericFuncRet f - in intercalateWith connArrow id $ map (hsargtype . fst) args ++ [hsrettype ret] - +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 ++ ")" + selfstr = "(Ptr " ++ rcname ++ ")" hsargtype (CT ctype _) = hsCTypeName ctype - hsargtype (CPT x _) = hsCppTypeName x + 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 + hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x -hscFuncName :: Class -> Function -> String +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 + +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) + +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) + 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) + 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 +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 :: Function -> Args genericFuncArgs (Destructor _) = [] genericFuncArgs f = func_args f - -aliasedFuncName :: Class -> Function -> String -aliasedFuncName c f = - case f of - Constructor _ a -> maybe (constructorName c) id a + +aliasedFuncName :: Class -> Function -> String +aliasedFuncName c f = + case f of + Constructor _ a -> maybe (constructorName c) id a Virtual _ str _ a -> maybe str id a NonVirtual _ str _ a-> maybe (nonvirtualName c str) id a Static _ str _ a -> maybe (nonvirtualName c str) id a - -- AliasVirtual _ _ _ alias -> alias + -- AliasVirtual _ _ _ alias -> alias Destructor a -> maybe destructorName id a -cppStaticName :: Class -> Function -> String +cppStaticName :: Class -> Function -> String cppStaticName c f = class_name c ++ "::" ++ func_name f -cppFuncName :: Class -> Function -> String -cppFuncName c f = case f of +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 + Virtual _ _ _ _ -> func_name f + NonVirtual _ _ _ _-> func_name f + Static _ _ _ _-> cppStaticName c f + -- AliasVirtual _ _ _ _ _ -> func_name f Destructor _ -> destructorName constructorName :: Class -> String -constructorName c = "new" ++ (fst.hsClassName) c - +constructorName c = "new" ++ (fst.hsClassName) c + nonvirtualName :: Class -> String -> String -nonvirtualName c str = (firstLower.fst.hsClassName) c ++ str +nonvirtualName c str = (firstLower.fst.hsClassName) c ++ str -destructorName :: String -destructorName = "delete" +destructorName :: String +destructorName = "delete" diff --git a/lib/FFICXX/Generate/Type/PackageInterface.hs b/lib/FFICXX/Generate/Type/PackageInterface.hs --- a/lib/FFICXX/Generate/Type/PackageInterface.hs +++ b/lib/FFICXX/Generate/Type/PackageInterface.hs @@ -16,10 +16,20 @@ import Data.Hashable import qualified Data.HashMap.Strict as HM +import Data.String 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) + +newtype HeaderName = HdrName { unHdrName :: String } + deriving (Hashable, Show, Eq, Ord) + + +instance IsString HeaderName where + fromString = HdrName + + + type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName diff --git a/sample/cxxlib/Makefile b/sample/cxxlib/Makefile new file mode 100644 --- /dev/null +++ b/sample/cxxlib/Makefile @@ -0,0 +1,10 @@ +TARGET = lib/libmysample.so +SOURCES = src/A.cpp src/B.cpp +CPPFLAGS = -Iinclude +CXXFLAGS = -fPIC +LDFLAGS = -shared -Wl,-soname,libmysample.so + +objects = $(patsubst %.cpp,%.o,$(SOURCES)) +$(TARGET): $(objects) + mkdir -p lib + $(CC) $(LDFLAGS) $(objects) -o $@ diff --git a/sample/cxxlib/build.sh b/sample/cxxlib/build.sh deleted file mode 100644 --- a/sample/cxxlib/build.sh +++ /dev/null @@ -1,6 +0,0 @@ -cd src -make -cd .. -mkdir -p lib -cp src/libmysample.so lib/libmysample.so - diff --git a/sample/cxxlib/src/Makefile b/sample/cxxlib/src/Makefile deleted file mode 100644 --- a/sample/cxxlib/src/Makefile +++ /dev/null @@ -1,9 +0,0 @@ -libmysample.so: A.o B.o - gcc -shared -Wl,-soname,libmysample.so -o libmysample.so A.o B.o - -A.o: A.cpp - g++ -fPIC -I../include -c A.cpp - -B.o: B.cpp - g++ -fPIC -I../include -c B.cpp - diff --git a/sample/mysample-generator/MySampleGen.hs b/sample/mysample-generator/MySampleGen.hs --- a/sample/mysample-generator/MySampleGen.hs +++ b/sample/mysample-generator/MySampleGen.hs @@ -1,10 +1,12 @@ {-# LANGUAGE ScopedTypeVariables #-} -import Data.Monoid (mempty) -import System.FilePath (()) -import System.Directory (getCurrentDirectory) +import Data.Default (def) +import Data.Monoid (mempty) +import System.FilePath (()) +import System.Directory (getCurrentDirectory) import Text.StringTemplate hiding (render) --- +-- +import FFICXX.Generate.Builder (mkCabalFile) import FFICXX.Generate.Code.Cabal import FFICXX.Generate.Code.Cpp import FFICXX.Generate.Code.Dependency @@ -12,141 +14,107 @@ import FFICXX.Generate.Code.Cpp import FFICXX.Generate.Code.Dependency import FFICXX.Generate.Config -import FFICXX.Generate.Generator.ContentMaker +import FFICXX.Generate.Generator.ContentMaker import FFICXX.Generate.Generator.Driver import FFICXX.Generate.Type.Annotate import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.PackageInterface -import FFICXX.Generate.Util --- +-- import qualified FFICXX.Paths_fficxx as F -mysampleclasses = [ ] +mysampleclasses = [ ] -mycabal = Cabal { cabal_pkgname = "MySample" +mycabal = Cabal { cabal_pkgname = "MySample" , cabal_cheaderprefix = "MySample" - , cabal_moduleprefix = "MySample" } + , cabal_moduleprefix = "MySample" + } -myclass = Class mycabal +myclass = Class mycabal -a :: Class -a = myclass "A" [] mempty Nothing +a :: Class +a = myclass "A" [] mempty Nothing [ Constructor [] Nothing , Virtual void_ "Foo" [ ] Nothing , Virtual void_ "Foo2" [ long "t" ] Nothing - ] + ] -b :: Class +b :: Class b = myclass "B" [a] mempty Nothing [ Constructor [] Nothing , Virtual void_ "Bar" [] Nothing - ] - -myclasses = [ a, b] - -toplevelfunctions = [ ] - - --- | -cabalTemplate :: String -cabalTemplate = "Pkg.cabal" - - --- | -mkCabalFile :: FFICXXConfig - -> STGroup String - -> (TopLevelImportHeader,[ClassModule]) - -> FilePath - -> IO () -mkCabalFile config templates (tih,classmodules) cabalfile = do - cpath <- getCurrentDirectory - - let str = renderTemplateGroup - templates - [ ("pkgname", "MySample") - , ("version", "0.0") - , ("license", "" ) - , ("buildtype", "Simple") - , ("deps", "" ) - , ("csrcFiles", genCsrcFiles (tih,classmodules)) - , ("includeFiles", genIncludeFiles "MySample" classmodules) - , ("cppFiles", genCppFiles (tih,classmodules)) - , ("exposedModules", genExposedModules "MySample" classmodules) - , ("otherModules", genOtherModules classmodules) - , ("extralibdirs", cpath ".." "cxxlib" "lib" ) -- this need to be changed - , ("extraincludedirs", cpath ".." "cxxlib" "include" ) -- this need to be changed - , ("extralib", ", mysample") - , ("cabalIndentation", cabalIndentation) - ] - cabalTemplate - writeFile cabalfile str + ] +myclasses = [ a, b] +toplevelfunctions = [ ] main :: IO () -main = do - putStrLn "generate mysample" - cwd <- getCurrentDirectory +main = do + putStrLn "generate mysample" + cwd <- getCurrentDirectory - let cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd + let mycabalattr = def + { cabalattr_extralibdirs = [cwd ".." "cxxlib" "lib"] + , cabalattr_extraincludedirs = [cwd ".." "cxxlib" "include"] + } + cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd , fficxxconfig_workingDir = cwd "working" - , fficxxconfig_installBaseDir = cwd "MySample" - } + , fficxxconfig_installBaseDir = cwd "MySample" + } workingDir = fficxxconfig_workingDir cfg - installDir = fficxxconfig_installBaseDir cfg - pkgname = "MySample" - (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH ("MySample", (\c->([],[class_name c ++ ".h"]))) (myclasses,toplevelfunctions) - hsbootlst = mkHSBOOTCandidateList mods - cglobal = mkGlobal myclasses - summarymodule = "MySample" + installDir = fficxxconfig_installBaseDir cfg + pkgname = "MySample" + (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH ("MySample", (\c->([],[HdrName $ class_name c ++ ".h"]))) (myclasses,toplevelfunctions) + hsbootlst = mkHSBOOTCandidateList mods + cglobal = mkGlobal myclasses + summarymodule = "MySample" cabalFileName = "MySample.cabal" + extralibs = ["mysample"] templateDir <- F.getDataDir >>= return . ( "template") - (templates :: STGroup String) <- directoryGroup templateDir - -- + (templates :: STGroup String) <- directoryGroup templateDir + -- notExistThenCreate workingDir - notExistThenCreate installDir - notExistThenCreate (installDir "src") + notExistThenCreate installDir + notExistThenCreate (installDir "src") notExistThenCreate (installDir "csrc") - -- - putStrLn "cabal file generation" - mkCabalFile cfg templates (tih,mods) (workingDir cabalFileName) - -- + -- + putStrLn "cabal file generation" + mkCabalFile cfg templates (mycabal, mycabalattr) summarymodule (tih, mods) extralibs (workingDir cabalFileName) + -- putStrLn "header file generation" writeTypeDeclHeaders templates workingDir (TypMcro "__MYSAMPLE__") pkgname cihs mapM_ (writeDeclHeaders templates workingDir (TypMcro "__MYSAMPLE__") pkgname) cihs - -- - putStrLn "cpp file generation" + -- + putStrLn "cpp file generation" mapM_ (writeCppDef templates workingDir) cihs - -- - putStrLn "RawType.hs file generation" - mapM_ (writeRawTypeHs templates workingDir) mods - -- + -- + putStrLn "RawType.hs file generation" + mapM_ (writeRawTypeHs templates workingDir) mods + -- putStrLn "FFI.hsc file generation" mapM_ (writeFFIHsc templates workingDir) mods - -- - putStrLn "Interface.hs file generation" + -- + putStrLn "Interface.hs file generation" mapM_ (writeInterfaceHs mempty templates workingDir) mods - -- + -- putStrLn "Cast.hs file generation" mapM_ (writeCastHs templates workingDir) mods - -- + -- putStrLn "Implementation.hs file generation" mapM_ (writeImplementationHs mempty templates workingDir) mods - -- - putStrLn "hs-boot file generation" - mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst - -- - putStrLn "module file generation" + -- + putStrLn "hs-boot file generation" + mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst + -- + putStrLn "module file generation" mapM_ (writeModuleHs templates workingDir) mods - -- + -- putStrLn "summary module generation generation" writePkgHs summarymodule templates workingDir mods tih - -- + -- putStrLn "copying" - copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) + copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) -- copyPredefined templateDir (srcDir ibase) pkgname copyCppFiles workingDir (csrcDir installDir) pkgname (tih,cihs) - mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods - - + mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods diff --git a/sample/snappy-generator/SnappyGen.hs b/sample/snappy-generator/SnappyGen.hs --- a/sample/snappy-generator/SnappyGen.hs +++ b/sample/snappy-generator/SnappyGen.hs @@ -2,6 +2,7 @@ -- import FFICXX.Generate.Builder import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.PackageInterface snappyclasses = [ ] @@ -65,8 +66,24 @@ , TopLevelFunction bool_ "IsValidCompressedBuffer" [ cstar CTChar "compressed", ulong "compressed_length" ] Nothing ] + + +headerMap = [ ("Sink" , ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"])) + , ("Source", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"])) + , ("ByteArraySource", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"])) + , ("UncheckedByteArraySink", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"])) + ] + +mycabalattr = + CabalAttr + { cabalattr_license = Nothing + , cabalattr_licensefile = Nothing + , cabalattr_extraincludedirs = [] + , cabalattr_extralibdirs = [] + } + main :: IO () main = do - simpleBuilder (mycabal,myclasses,toplevelfunctions) + simpleBuilder "Snappy" headerMap (mycabal,mycabalattr,myclasses,toplevelfunctions) [ "snappy" ] diff --git a/sample/snappy-generator/testSnappy.hs b/sample/snappy-generator/testSnappy.hs new file mode 100644 --- /dev/null +++ b/sample/snappy-generator/testSnappy.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +import Control.Applicative ((<$>),(<*>),pure) +import Control.Monad (when) +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Unsafe as BU + + +import Foreign.C +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable as S + +import System.Environment + +import Snappy + + +main :: IO () +main = do + putStrLn "test Snappy" + + args <- getArgs + when (length args /= 1) $ do + error "./testSnappy [filename]" + bstr <- B.readFile (head args) + + (obstr,len) <- BU.unsafeUseAsCString bstr $ \cstr -> do + p_ostr <- mallocArray 1000 + p_len <- malloc :: IO (Ptr CULong) + rawCompress cstr 1000 p_ostr p_len + len <- S.peek p_len + putStrLn $ "compressed size = " ++ (show len) + (,) <$> BU.unsafePackCString p_ostr <*> pure len + + rstr <- BU.unsafeUseAsCString obstr $ \cstr -> do + p_ostr <- mallocArray 10000 + b <- rawUncompress cstr len p_ostr + putStrLn $ "success? " ++ show b + BU.unsafePackCString p_ostr + + B.putStrLn rstr + + return () + + diff --git a/template/Pkg.cabal.st b/template/Pkg.cabal.st --- a/template/Pkg.cabal.st +++ b/template/Pkg.cabal.st @@ -3,15 +3,15 @@ Synopsis: $synopsis$ Description: $description$ Homepage: $homepage$ -License: $license$ -License-file: $licensefile$ +$licenseField$ +$licenseFileField$ Author: $author$ Maintainer: $maintainer$ Category: $category$ Tested-with: GHC >= 7.6 Build-Type: $buildtype$ cabal-version: >=1.10 -Extra-source-files: +Extra-source-files: $cabalIndentation$CHANGES $cabalIndentation$Config.hs $csrcFiles$ @@ -23,19 +23,20 @@ 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$ + cc-options: $ccOptions$ + Build-Depends: base>4 && < 5, fficxx-runtime >= 0.2 $deps$ Exposed-Modules: -$exposedModules$ +$exposedModules$ Other-Modules: $otherModules$ extra-lib-dirs: $extralibdirs$ - extra-libraries: stdc++ $extralib$ - Include-dirs: csrc $extraincludedirs$ - Install-includes: + extra-libraries: stdc++ $extraLibraries$ + Include-dirs: csrc $extraincludedirs$ + Install-includes: $includeFiles$ - C-sources: + C-sources: $cppFiles$ - +