fficxx 0.2 → 0.2.1

raw patch · 18 files changed

+608/−504 lines, 18 filesdep +data-defaultdep ~errorsPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-default

Dependency ranges changed: errors

API changes (from Hackage documentation)

Files

• fficxx.cabal +18/−18
• lib/FFICXX/Generate/Builder.hs +116/−82
• lib/FFICXX/Generate/Code/Cabal.hs +0/−8
• lib/FFICXX/Generate/Code/Cpp.hs +12/−9
• lib/FFICXX/Generate/Code/Dependency.hs +22/−20
• lib/FFICXX/Generate/Code/HsFFI.hs +6/−5
• lib/FFICXX/Generate/Code/HsFrontEnd.hs +3/−2
• lib/FFICXX/Generate/Generator/ContentMaker.hs +8/−6
• lib/FFICXX/Generate/Generator/Driver.hs +3/−6
• lib/FFICXX/Generate/Type/Class.hs +259/−225
• lib/FFICXX/Generate/Type/PackageInterface.hs +11/−1
• sample/cxxlib/Makefile +10/−0
• sample/cxxlib/build.sh +0/−6
• sample/cxxlib/src/Makefile +0/−9
• sample/mysample-generator/MySampleGen.hs +64/−96
• sample/snappy-generator/SnappyGen.hs +18/−1
• sample/snappy-generator/testSnappy.hs +47/−0
• template/Pkg.cabal.st +11/−10

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

@@ -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 <ianwookim@gmail.com>@@ -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 ()

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

@@ -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 <ianwookim@gmail.com>@@ -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 ## _t, Type>((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 ## _t, Type>((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' 

@@ -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 <ianwookim@gmail.com>@@ -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) = 

@@ -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 <ianwookim@gmail.com>@@ -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)

@@ -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 <ianwookim@gmail.com>

@@ -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 <ianwookim@gmail.com>@@ -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 

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

@@ -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 <ianwookim@gmail.com>@@ -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"

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

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

@@ -1,6 +0,0 @@-cd src -make -cd ..-mkdir -p lib-cp src/libmysample.so lib/libmysample.so -

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

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

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

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

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