diff --git a/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -1,20 +1,15 @@ -Name: fficxx -Version: 0.2.1 -Synopsis: automatic C++ binding generation -Description: automatic C++ binding generation +Name: fficxx +Version: 0.3 +Synopsis: automatic C++ binding generation +Description: automatic C++ binding generation License: BSD3 -License-file: LICENSE -Author: Ian-Woo Kim -Maintainer: Ian-Woo Kim -Build-Type: Simple +License-file: LICENSE +Author: Ian-Woo Kim +Maintainer: Ian-Woo Kim +Build-Type: Simple Category: FFI Tools Cabal-Version: >= 1.8 -Data-files: template/*.h.st - template/*.hs.st - template/*.hsc.st - template/*.hs-boot.st - template/*.cpp.st - template/Pkg.cabal.st +Data-files: sample/cxxlib/include/*.h sample/cxxlib/src/*.cpp sample/cxxlib/Makefile @@ -29,33 +24,33 @@ Library hs-source-dirs: lib - ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind + ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind ghc-prof-options: -caf-all -auto-all Build-Depends: base == 4.*, - data-default, - mtl>2, + Cabal, + bytestring, containers, - filepath>1, + data-default, directory, - HStringTemplate, - split, - process, - transformers >= 0.3, - template-haskell, + either, + errors, + filepath>1, hashable, - unordered-containers, + haskell-src-exts, lens > 3, - either, - errors < 2.0, - bytestring, + mtl>2, + process, pureMD5, - Cabal + split, + transformers >= 0.3, + template, + template-haskell, + text, + unordered-containers + Exposed-Modules: FFICXX.Generate.Builder - FFICXX.Generate.Type.Class - FFICXX.Generate.Type.Module - FFICXX.Generate.Type.PackageInterface FFICXX.Generate.Config FFICXX.Generate.Code.MethodDef FFICXX.Generate.Code.Cpp @@ -63,12 +58,13 @@ FFICXX.Generate.Code.HsFFI FFICXX.Generate.Code.Cabal FFICXX.Generate.Code.Dependency - FFICXX.Generate.Generator.Driver - FFICXX.Generate.Generator.ContentMaker - FFICXX.Generate.Util + FFICXX.Generate.ContentMaker FFICXX.Generate.QQ.Verbatim + FFICXX.Generate.Util + FFICXX.Generate.Util.HaskellSrcExts FFICXX.Generate.Type.Annotate - FFICXX.Paths_fficxx - Other-Modules: - Paths_fficxx + 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 @@ -1,9 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Builder --- Copyright : (c) 2011-2013,2015 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -14,97 +15,40 @@ module FFICXX.Generate.Builder where -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 Control.Monad ( forM_, void, when ) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Char ( toUpper ) +import Data.Digest.Pure.MD5 ( md5 ) +import qualified Data.HashMap.Strict as HM +import Data.Monoid ( (<>), mempty ) +import Language.Haskell.Exts.Pretty ( prettyPrint ) +import System.FilePath ( (), (<.>), splitExtension ) +import System.Directory ( copyFile, doesDirectoryExist + , doesFileExist, getCurrentDirectory ) +import System.IO ( hPutStrLn, withFile, IOMode(..) ) +import System.Process ( readProcess, system ) -- import FFICXX.Generate.Code.Cabal -import FFICXX.Generate.Code.Cpp import FFICXX.Generate.Code.Dependency import FFICXX.Generate.Config -import FFICXX.Generate.Code.Cpp -import FFICXX.Generate.Code.Dependency -import FFICXX.Generate.Config -import FFICXX.Generate.Generator.ContentMaker -import FFICXX.Generate.Generator.Driver -import FFICXX.Generate.Type.Annotate -import FFICXX.Generate.Type.Class ( Cabal(..) - , CabalAttr(..) - , Class - , ClassModule - , Namespace(NS) - , TopLevelFunction - , TopLevelImportHeader - ) +import FFICXX.Generate.ContentMaker +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Generate.Util -- -import qualified FFICXX.Paths_fficxx as F --- | -cabalTemplate :: String -cabalTemplate = "Pkg.cabal" - - --- | -mkCabalFile :: FFICXXConfig - -> STGroup String - -> (Cabal, CabalAttr) - -> String - -> (TopLevelImportHeader,[ClassModule]) - -> [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 = map ((\x->if x=='-' then '_' else x) . toUpper) simpleBuilder :: String -> [(String,([Namespace],[HeaderName]))] - -> (Cabal, CabalAttr, [Class], [TopLevelFunction]) + -> (Cabal, CabalAttr, [Class], [TopLevelFunction], [(TemplateClass,HeaderName)]) -> [String] -- ^ extra libs + -> [(String,[String])] -- ^ extra module -> IO () -simpleBuilder summarymodule m (cabal, cabalattr, myclasses, toplevelfunctions) extralibs = do +simpleBuilder summarymodule lst (cabal, cabalattr, classes, toplevelfunctions, templates) extralibs extramods = do let pkgname = cabal_pkgname cabal - putStrLn ("generating " ++ pkgname) + putStrLn ("generating " <> pkgname) cwd <- getCurrentDirectory let cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd , fficxxconfig_workingDir = cwd "working" @@ -113,15 +57,10 @@ workingDir = fficxxconfig_workingDir cfg installDir = fficxxconfig_installBaseDir cfg - (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH - (pkgname, mkClassNSHeaderFromMap (HM.fromList m)) - (myclasses, toplevelfunctions) + pkgconfig@(PkgConfig mods cihs tih tcms _tcihs) = + mkPackageConfig (pkgname, mkClassNSHeaderFromMap (HM.fromList lst)) (classes, toplevelfunctions,templates,extramods) hsbootlst = mkHSBOOTCandidateList mods - cglobal = mkGlobal myclasses - -- summarymodule = -- pkgname -- "Snappy" - cabalFileName = pkgname <.> "cabal" -- "Snappy.cabal" - templateDir <- F.getDataDir >>= return . ( "template") - (templates :: STGroup String) <- directoryGroup templateDir + cabalFileName = pkgname <.> "cabal" -- notExistThenCreate workingDir notExistThenCreate installDir @@ -129,55 +68,149 @@ notExistThenCreate (installDir "csrc") -- putStrLn "cabal file generation" - mkCabalFile cfg templates (cabal, cabalattr) summarymodule (tih,mods) extralibs (workingDir cabalFileName) + buildCabalFile (cabal,cabalattr) summarymodule pkgconfig extralibs (workingDircabalFileName) -- 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 + let typmacro = TypMcro ("__" <> macrofy (cabal_pkgname cabal) <> "__") + gen :: FilePath -> String -> IO () + gen file str = + let path = workingDir file in withFile path WriteMode (flip hPutStrLn str) + + + gen (pkgname <> "Type.h") (buildTypeDeclHeader typmacro (map cihClass cihs)) + mapM_ (\hdr -> gen (unHdrName (cihSelfHeader hdr)) (buildDeclHeader typmacro pkgname hdr)) cihs + gen (tihHeaderFileName tih <.> "h") (buildTopLevelFunctionHeader typmacro pkgname tih) + forM_ tcms $ \m -> + let tcihs = tcmTCIH m + in forM_ tcihs $ \tcih -> + let t = tcihTClass tcih + hdr = unHdrName (tcihSelfHeader tcih) + in gen hdr (buildTemplateHeader typmacro t) -- putStrLn "cpp file generation" - mapM_ (writeCppDef templates workingDir) cihs - writeTopLevelFunctionCppDef templates workingDir typmacro pkgname tih + mapM_ (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) cihs + gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelFunctionCppDef tih) -- putStrLn "RawType.hs file generation" - mapM_ (writeRawTypeHs templates workingDir) mods + mapM_ (\m -> gen (cmModule m <.> "RawType" <.> "hs") (prettyPrint (buildRawTypeHs m))) mods -- putStrLn "FFI.hsc file generation" - mapM_ (writeFFIHsc templates workingDir) mods + mapM_ (\m -> gen (cmModule m <.> "FFI" <.> "hsc") (prettyPrint (buildFFIHsc m))) mods -- putStrLn "Interface.hs file generation" - mapM_ (writeInterfaceHs mempty templates workingDir) mods + mapM_ (\m -> gen (cmModule m <.> "Interface" <.> "hs") (prettyPrint (buildInterfaceHs mempty m))) mods -- putStrLn "Cast.hs file generation" - mapM_ (writeCastHs templates workingDir) mods + mapM_ (\m -> gen (cmModule m <.> "Cast" <.> "hs") (prettyPrint (buildCastHs m))) mods -- putStrLn "Implementation.hs file generation" - mapM_ (writeImplementationHs mempty templates workingDir) mods + mapM_ (\m -> gen (cmModule m <.> "Implementation" <.> "hs") (prettyPrint (buildImplementationHs mempty m))) mods -- + putStrLn "Template.hs file generation" + mapM_ (\m -> gen (tcmModule m <.> "Template" <.> "hs") (prettyPrint (buildTemplateHs m))) tcms + -- + putStrLn "TH.hs file generation" + mapM_ (\m -> gen (tcmModule m <.> "TH" <.> "hs") (prettyPrint (buildTHHs m))) tcms + + + -- putStrLn "hs-boot file generation" - mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst + mapM_ (\m -> gen (m <.> "Interface" <.> "hs-boot") (prettyPrint (buildInterfaceHSBOOT m))) hsbootlst -- + + + putStrLn "module file generation" - mapM_ (writeModuleHs templates workingDir) mods + mapM_ (\m -> gen (cmModule m <.> "hs") (prettyPrint (buildModuleHs m))) mods -- putStrLn "summary module generation generation" - writePkgHs summarymodule templates workingDir mods tih + gen (summarymodule <.> "hs") (buildPkgHs summarymodule mods tih) -- putStrLn "copying" 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 + copyCppFiles workingDir (csrcDir installDir) pkgname pkgconfig + mapM_ (copyModule workingDir (srcDir installDir)) mods + mapM_ (copyTemplateModule workingDir (srcDir installDir)) tcms + moduleFileCopy workingDir (srcDir installDir) $ summarymodule <.> "hs" -- | some dirty hack. later, we will do it with more proper approcah. touch :: FilePath -> IO () -touch fp = do - readProcess "touch" [fp] "" - return () +touch fp = void (readProcess "touch" [fp] "") + + +notExistThenCreate :: FilePath -> IO () +notExistThenCreate dir = do + b <- doesDirectoryExist dir + if b then return () else system ("mkdir -p " <> dir) >> return () + + +copyFileWithMD5Check :: FilePath -> FilePath -> IO () +copyFileWithMD5Check src tgt = do + b <- doesFileExist tgt + if b + then do + srcmd5 <- md5 <$> L.readFile src + tgtmd5 <- md5 <$> L.readFile tgt + if srcmd5 == tgtmd5 then return () else copyFile src tgt + else copyFile src tgt + + +copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO () +copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs) = do + let thfile = cprefix <> "Type.h" + tlhfile = tihHeaderFileName tih <.> "h" + tlcppfile = tihHeaderFileName tih <.> "cpp" + copyFileWithMD5Check (wdir thfile) (ddir thfile) + doesFileExist (wdir tlhfile) + >>= flip when (copyFileWithMD5Check (wdir tlhfile) (ddir tlhfile)) + doesFileExist (wdir tlcppfile) + >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) + forM_ cihs $ \header-> do + let hfile = unHdrName (cihSelfHeader header) + cppfile = cihSelfCpp header + copyFileWithMD5Check (wdir hfile) (ddir hfile) + copyFileWithMD5Check (wdir cppfile) (ddir cppfile) + + forM_ tcihs $ \header-> do + let hfile = unHdrName (tcihSelfHeader header) + copyFileWithMD5Check (wdir hfile) (ddir hfile) + + +moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO () +moduleFileCopy wdir ddir fname = do + let (fnamebody,fnameext) = splitExtension fname + (mdir,mfile) = moduleDirFile fnamebody + origfpath = wdir fname + (mfile',_mext') = splitExtension mfile + newfpath = ddir mdir mfile' <> fnameext + b <- doesFileExist origfpath + when b $ do + notExistThenCreate (ddir mdir) + copyFileWithMD5Check origfpath newfpath + + +copyModule :: FilePath -> FilePath -> ClassModule -> IO () +copyModule wdir ddir m = do + let modbase = cmModule m + + moduleFileCopy wdir ddir $ modbase <> ".hs" + moduleFileCopy wdir ddir $ modbase <> ".RawType.hs" + moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc" + moduleFileCopy wdir ddir $ modbase <> ".Interface.hs" + moduleFileCopy wdir ddir $ modbase <> ".Cast.hs" + moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs" + moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot" + return () + +copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO () +copyTemplateModule wdir ddir m = do + let modbase = tcmModule m + moduleFileCopy wdir ddir $ modbase <> ".Template.hs" + moduleFileCopy wdir ddir $ modbase <> ".TH.hs" + 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 @@ -1,7 +1,9 @@ +{-# LANGUAGE OverloadedStrings #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cabal --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -12,25 +14,167 @@ module FFICXX.Generate.Code.Cabal where -import FFICXX.Generate.Type.Class +import Data.List ( intercalate, nub ) +import Data.Monoid ( (<>) ) +import Data.Text ( Text ) +import System.FilePath ( (<.>), () ) +-- +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Module +import FFICXX.Generate.Type.PackageInterface +import FFICXX.Generate.Util + cabalIndentation :: String cabalIndentation = replicate 23 ' ' +genIncludeFiles :: String -- ^ package name + -> ([ClassImportHeader],[TemplateClassImportHeader]) + -> String +genIncludeFiles pkgname (cih,tcih) = + let indent = cabalIndentation + selfheaders = map cihSelfHeader cih <> map tcihSelfHeader tcih + -- selfheaders = nub selfheaders' + includeFileStrs = map ((indent<>).unHdrName) selfheaders + in unlines ((indent<>pkgname<>"Type.h") : includeFileStrs) + +genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> String +genCsrcFiles (tih,cmods) = + let indent = cabalIndentation + selfheaders' = do + x <- cmods + y <- cmCIH x + return (cihSelfHeader y) + selfheaders = nub selfheaders' + selfcpp' = do + x <- cmods + y <- cmCIH x + return (cihSelfCpp y) + selfcpp = nub selfcpp' + tlh = tihHeaderFileName tih <.> "h" + tlcpp = tihHeaderFileName tih <.> "cpp" + 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) + + in unlines (includeFileStrsWithCsrc <> cppFilesWithCsrc) + +genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> String +genCppFiles (tih,cmods) = + let indent = cabalIndentation + selfcpp' = do + x <- cmods + y <- cmCIH x + return (cihSelfCpp y) + selfcpp = nub selfcpp' + tlcpp = tihHeaderFileName tih <.> "cpp" + cppFileStrs = map (\x->indent<> "csrc" x) + (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) + in unlines cppFileStrs + + + -- | generate exposed module list in cabal file -genExposedModules :: String -> [ClassModule] -> String -genExposedModules summarymod cmods = +genExposedModules :: String -> ([ClassModule],[TemplateClassModule]) -> String +genExposedModules summarymod (cmods,tmods) = let indentspace = cabalIndentation - summarystrs = indentspace ++ summarymod - cmodstrs = map ((\x->indentspace++x).cmModule) cmods - rawType = map ((\x->indentspace++x++".RawType").cmModule) cmods - ffi = map ((\x->indentspace++x++".FFI").cmModule) cmods - interface= map ((\x->indentspace++x++".Interface").cmModule) cmods - cast = map ((\x->indentspace++x++".Cast").cmModule) cmods - implementation = map ((\x->indentspace++x++".Implementation").cmModule) cmods - in unlines ([summarystrs]++cmodstrs++rawType++ffi++interface++cast++implementation) + summarystrs = indentspace <> summarymod + cmodstrs = map ((\x->indentspace<>x).cmModule) cmods + rawType = map ((\x->indentspace<>x<>".RawType").cmModule) cmods + ffi = map ((\x->indentspace<>x<>".FFI").cmModule) cmods + interface= map ((\x->indentspace<>x<>".Interface").cmModule) cmods + cast = map ((\x->indentspace<>x<>".Cast").cmModule) cmods + implementation = map ((\x->indentspace<>x<>".Implementation").cmModule) cmods + template = map ((\x->indentspace<>x<>".Template").tcmModule) tmods + th = map ((\x->indentspace<>x<>".TH").tcmModule) tmods + in unlines ([summarystrs]<>cmodstrs<>rawType<>ffi<>interface<>cast<>implementation<>template<>th) -- | generate other modules in cabal file genOtherModules :: [ClassModule] -> String genOtherModules _cmods = "" + + +-- | +cabalTemplate :: Text +cabalTemplate = + "Name: $pkgname\n\ + \Version: $version\n\ + \Synopsis: $synopsis\n\ + \Description: $description\n\ + \Homepage: $homepage\n\ + \$licenseField\n\ + \$licenseFileField\n\ + \Author: $author\n\ + \Maintainer: $maintainer\n\ + \Category: $category\n\ + \Tested-with: GHC >= 7.6\n\ + \Build-Type: $buildtype\n\ + \cabal-version: >=1.10\n\ + \Extra-source-files:\n\ + \$csrcFiles\n\ + \\n\ + \$sourcerepository\n\ + \\n\ + \Library\n\ + \ default-language: Haskell2010\n\ + \ hs-source-dirs: src\n\ + \ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\ + \ ghc-prof-options: -caf-all -auto-all\n\ + \ cc-options: $ccOptions\n\ + \ Build-Depends: base>4 && < 5, fficxx >= 0.3, fficxx-runtime >= 0.3, template-haskell$deps\n\ + \ Exposed-Modules:\n\ + \$exposedModules\n\ + \ Other-Modules:\n\ + \$otherModules\n\ + \ extra-lib-dirs: $extralibdirs\n\ + \ extra-libraries: stdc++ $extraLibraries\n\ + \ Include-dirs: csrc $extraincludedirs\n\ + \ Install-includes:\n\ + \$includeFiles\n\ + \ C-sources:\n\ + \$cppFiles\n" + +-- | +buildCabalFile :: (Cabal, CabalAttr) + -> String + -> PackageConfig -- (TopLevelImportHeader,[ClassModule],[TemplateClassModule]) + -> [String] -- ^ extra libs + -> FilePath + -> IO () +buildCabalFile (cabal, cabalattr) summarymodule pkgconfig extralibs cabalfile = do + let tih = pcfg_topLevelImportHeader pkgconfig + classmodules = pcfg_classModules pkgconfig + cih = pcfg_classImportHeaders pkgconfig + tmods = pcfg_templateClassModules pkgconfig + tcih = pcfg_templateClassImportHeaders pkgconfig + txt = subst cabalTemplate + (context ([ ("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") + , ("synopsis", "") + , ("description", "") + , ("homepage","") + , ("author","") + , ("maintainer","") + , ("category","") + , ("sourcerepository","") + , ("ccOptions","-std=c++14") + , ("deps", "") + , ("csrcFiles", genCsrcFiles (tih,classmodules)) + , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) (cih,tcih) ) + , ("cppFiles", genCppFiles (tih,classmodules)) + , ("exposedModules", genExposedModules summarymodule (classmodules,tmods)) + , ("otherModules", genOtherModules classmodules) + , ("extralibdirs", intercalate ", " $ cabalattr_extralibdirs cabalattr) + , ("extraincludedirs", intercalate ", " $ cabalattr_extraincludedirs cabalattr) + , ("extraLibraries", concatMap (", " <>) extralibs) + , ("cabalIndentation", cabalIndentation) + ])) + writeFile cabalfile txt + 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 @@ -1,9 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cpp --- Copyright : (c) 2011-2013,2015 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -14,17 +15,19 @@ module FFICXX.Generate.Code.Cpp where -import Data.Char -import Data.List -import System.FilePath - -import FFICXX.Generate.Util -import FFICXX.Generate.Code.MethodDef -import FFICXX.Generate.Code.Cabal -import FFICXX.Generate.Type.Class -import FFICXX.Generate.Type.PackageInterface +import Data.Char +import Data.Monoid ( (<>) ) +-- +import FFICXX.Generate.Util +import FFICXX.Generate.Code.MethodDef +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Module +import FFICXX.Generate.Type.PackageInterface +-- +-- -- Class Declaration and Definition +-- ---- ---- Declaration @@ -33,11 +36,11 @@ ---- "Class Type Declaration" Instances genCppHeaderTmplType :: Class -> String -genCppHeaderTmplType c = let tmpl = "// Opaque type definition for $classname$ \n\ - \typedef struct $classname$_tag $classname$_t; \n\ - \typedef $classname$_t * $classname$_p; \n\ - \typedef $classname$_t const* const_$classname$_p; \n" - in render tmpl [ ("classname", class_name c) ] +genCppHeaderTmplType c = let tmpl = "// Opaque type definition for $classname \n\ + \typedef struct ${classname}_tag ${classname}_t; \n\ + \typedef ${classname}_t * ${classname}_p; \n\ + \typedef ${classname}_t const* const_${classname}_p; \n" + in subst tmpl (context [ ("classname", class_name c) ]) genAllCppHeaderTmplType :: [Class] -> String genAllCppHeaderTmplType = intercalateWith connRet2 (genCppHeaderTmplType) @@ -46,11 +49,10 @@ genCppHeaderTmplVirtual :: Class -> String genCppHeaderTmplVirtual aclass = - let tmpl = "#undef $classname$_DECL_VIRT\\\n#define $classname$_DECL_VIRT(Type) \\\\\\\n$funcdecl$" - declBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) - , ("funcdecl" , funcDeclStr ) ] + let tmpl = "#undef ${classname}_DECL_VIRT \n#define ${classname}_DECL_VIRT(Type) \\\n${funcdecl}" funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass - in declBodyStr + in subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) + , ("funcdecl" , funcDeclStr ) ]) genAllCppHeaderTmplVirtual :: [Class] -> String genAllCppHeaderTmplVirtual = intercalateWith connRet2 genCppHeaderTmplVirtual @@ -59,9 +61,9 @@ genCppHeaderTmplNonVirtual :: Class -> String genCppHeaderTmplNonVirtual c = - let tmpl = "#undef $classname$_DECL_NONVIRT\\\n#define $classname$_DECL_NONVIRT(Type) \\\\\\\n$funcdecl$" - declBodyStr = render tmpl [ ("classname", map toUpper (class_name c) ) - , ("funcdecl" , funcDeclStr ) ] + let tmpl = "#undef ${classname}_DECL_NONVIRT \n#define ${classname}_DECL_NONVIRT(Type) \\\n$funcdecl" + declBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name c)) + , ("funcdecl" , funcDeclStr ) ]) funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc) . class_funcs $ c in declBodyStr @@ -74,12 +76,12 @@ genCppHeaderInstVirtual :: (Class,Class) -> String genCppHeaderInstVirtual (p,c) = let strc = map toUpper (class_name p) - in strc++"_DECL_VIRT(" ++ class_name c ++ ");\n" + in strc<>"_DECL_VIRT(" <> class_name c <> ");\n" genCppHeaderInstNonVirtual :: Class -> String genCppHeaderInstNonVirtual c = let strx = map toUpper (class_name c) - in strx++"_DECL_NONVIRT(" ++ class_name c ++ ");\n" + in strx<>"_DECL_NONVIRT(" <> class_name c <> ");\n" genAllCppHeaderInstNonVirtual :: [Class] -> String genAllCppHeaderInstNonVirtual = @@ -94,9 +96,9 @@ genCppDefTmplVirtual :: Class -> String genCppDefTmplVirtual aclass = - let tmpl = "#undef $classname$_DEF_VIRT\\\n#define $classname$_DEF_VIRT(Type)\\\\\\\n$funcdef$" - defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) - , ("funcdef" , funcDefStr ) ] + let tmpl = "#undef ${classname}_DEF_VIRT\n#define ${classname}_DEF_VIRT(Type)\\\n$funcdef" + defBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) + , ("funcdef" , funcDefStr ) ]) funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass in defBodyStr @@ -107,9 +109,9 @@ genCppDefTmplNonVirtual :: Class -> String genCppDefTmplNonVirtual aclass = - let tmpl = "#undef $classname$_DEF_NONVIRT\\\n#define $classname$_DEF_NONVIRT(Type)\\\\\\\n$funcdef$" - defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) - , ("funcdef" , funcDefStr ) ] + let tmpl = "#undef ${classname}_DEF_NONVIRT\n#define ${classname}_DEF_NONVIRT(Type)\\\n$funcdef" + defBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) + , ("funcdef" , funcDefStr ) ]) funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc) . class_funcs $ aclass in defBodyStr @@ -122,144 +124,112 @@ genCppDefInstVirtual :: (Class,Class) -> String genCppDefInstVirtual (p,c) = let strc = map toUpper (class_name p) - in strc++"_DEF_VIRT(" ++ class_name c ++ ")\n" + in strc<>"_DEF_VIRT(" <> class_name c <> ")\n" genCppDefInstNonVirtual :: Class -> String genCppDefInstNonVirtual c = - let tmpl = "$capitalclassname$_DEF_NONVIRT($classname$)" - in render tmpl [ ("capitalclassname", toUppers (class_name c)) - , ("classname", class_name c) ] + subst "${capitalclassname}_DEF_NONVIRT(${classname})" + (context [ ("capitalclassname", toUppers (class_name c)) + , ("classname" , class_name c ) ]) genAllCppDefInstNonVirtual :: [Class] -> String -genAllCppDefInstNonVirtual = - intercalateWith connRet genCppDefInstNonVirtual - ------ - +genAllCppDefInstNonVirtual = intercalateWith connRet genCppDefInstNonVirtual ----------------- genAllCppHeaderInclude :: ClassImportHeader -> String genAllCppHeaderInclude header = - intercalateWith connRet (\x->"#include \""++x++"\"") $ + intercalateWith connRet (\x->"#include \""<>x<>"\"") $ map unHdrName (cihIncludedHPkgHeadersInCPP header - ++ cihIncludedCPkgHeaders header) - - -genModuleIncludeHeader :: [ClassImportHeader] -> String -genModuleIncludeHeader headers = - let strlst = map ((\x->"#include \""++x++"\"") . unHdrName . cihSelfHeader) headers - in intercalate "\n" strlst + <> cihIncludedCPkgHeaders header) ---- -genIncludeFiles :: String -- ^ package name - -> [ClassModule] - -> String -genIncludeFiles pkgname cmods = - let indent = cabalIndentation - selfheaders' = do - x <- cmods - y <- cmCIH x - return (cihSelfHeader y) - selfheaders = nub selfheaders' - includeFileStrs = map ((indent++).unHdrName) selfheaders - in unlines ((indent++pkgname++"Type.h") : includeFileStrs) -genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> String -genCsrcFiles (tih,cmods) = - let indent = cabalIndentation - selfheaders' = do - x <- cmods - y <- cmCIH x - return (cihSelfHeader y) - selfheaders = nub selfheaders' - selfcpp' = do - x <- cmods - y <- cmCIH x - return (cihSelfCpp y) - selfcpp = nub selfcpp' - tlh = tihHeaderFileName tih <.> "h" - tlcpp = tihHeaderFileName tih <.> "cpp" - 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) - - in unlines (includeFileStrsWithCsrc ++ cppFilesWithCsrc) -genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> String -genCppFiles (tih,cmods) = - let indent = cabalIndentation - selfcpp' = do - x <- cmods - y <- cmCIH x - return (cihSelfCpp y) - selfcpp = nub selfcpp' - tlcpp = tihHeaderFileName tih <.> "cpp" - cppFileStrs = map (\x->indent++ "csrc" x) - (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) - in unlines cppFileStrs - - - ------------------------- -- TOP LEVEL FUNCTIONS -- ------------------------- genTopLevelFuncCppHeader :: TopLevelFunction -> String genTopLevelFuncCppHeader TopLevelFunction {..} = - let tmpl = "$returntype$ $funcname$ ( $args$ );" - in render tmpl [ ("returntype", rettypeToString toplevelfunc_ret) - , ("funcname", "TopLevel_" - ++ maybe toplevelfunc_name id toplevelfunc_alias) - , ("args", argsToStringNoSelf toplevelfunc_args) ] + subst "$returntype $funcname ( $args );" + (context [ ("returntype", rettypeToString toplevelfunc_ret ) + , ("funcname" , "TopLevel_" + <> maybe toplevelfunc_name id toplevelfunc_alias) + , ("args" , argsToStringNoSelf toplevelfunc_args ) ]) genTopLevelFuncCppHeader TopLevelVariable {..} = - let tmpl = "$returntype$ $funcname$ ( );" - in render tmpl [ ("returntype", rettypeToString toplevelvar_ret) - , ("funcname", "TopLevel_" - ++ maybe toplevelvar_name id toplevelvar_alias) - ] + subst "$returntype $funcname ( );" + (context [ ("returntype", rettypeToString toplevelvar_ret ) + , ("funcname" , "TopLevel_" + <> maybe toplevelvar_name id toplevelvar_alias) ]) genTopLevelFuncCppDefinition :: TopLevelFunction -> String genTopLevelFuncCppDefinition TopLevelFunction {..} = - let tmpl = "$returntype$ $funcname$ ( $args$ ) { \\\n $funcbody$\\\n}" - callstr = toplevelfunc_name ++ "(" - ++ argsToCallString toplevelfunc_args - ++ ")" - returnstr = case toplevelfunc_ret of - Void -> callstr ++ ";" - SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" - (CT (CRef _) _) -> "return ((*)"++callstr++");" - (CT _ctyp _isconst) -> "return "++callstr++";" - (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str - ++">(("++str++"*)"++callstr++");" - where str = class_name c' - (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" - funcDefStr = returnstr - in render tmpl [ ("returntype", rettypeToString toplevelfunc_ret) - , ("funcname", "TopLevel_" - ++ maybe toplevelfunc_name id toplevelfunc_alias) - , ("args", argsToStringNoSelf toplevelfunc_args) - , ("funcbody", funcDefStr ) - ] + let tmpl = "$returntype $funcname ( $args ) { \n $funcbody\n}" + callstr = toplevelfunc_name <> "(" + <> argsToCallString toplevelfunc_args + <> ")" + funcDefStr = returnCpp False (toplevelfunc_ret) callstr + in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret ) + , ("funcname" , "TopLevel_" + <> maybe toplevelfunc_name id toplevelfunc_alias) + , ("args" , argsToStringNoSelf toplevelfunc_args ) + , ("funcbody" , funcDefStr ) ]) genTopLevelFuncCppDefinition TopLevelVariable {..} = - let tmpl = "$returntype$ $funcname$ ( ) { \\\n $funcbody$\\\n}" - callstr = toplevelvar_name - returnstr = case toplevelvar_ret of - Void -> callstr ++ ";" - SelfType -> "return to_nonconst((Type *)" ++ 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' - (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" - funcDefStr = returnstr - in render tmpl [ ("returntype", rettypeToString toplevelvar_ret) - , ("funcname", "TopLevel_" - ++ maybe toplevelvar_name id toplevelvar_alias) - , ("funcbody", funcDefStr ) - ] + let tmpl = "$returntype $funcname ( ) { \n $funcbody\n}" + callstr = toplevelvar_name + funcDefStr = returnCpp False (toplevelvar_ret) callstr + in subst tmpl (context [ ("returntype", rettypeToString toplevelvar_ret ) + , ("funcname" , "TopLevel_" + <> maybe toplevelvar_name id toplevelvar_alias) + , ("funcbody" , funcDefStr ) ]) +genTmplFunCpp :: Bool -- ^ is for simple type? + -> TemplateClass + -> TemplateFunction + -> String +genTmplFunCpp b t@TmplCls {..} f = subst tmpl ctxt + where + tmpl = "#define ${tname}_${fname}${suffix}(Type) \\\n\ + \ extern \"C\" { \\\n\ + \ $decl; \\\n\ + \ } \\\n\ + \ inline $defn \\\n\ + \ auto a_${tname}_${fname}_ ## Type = ${tname}_${fname}_ ## Type ;\n" + ctxt = context . (("suffix",if b then "_s" else ""):) $ + case f of + TFunNew {..} -> [ ("tname" , tclass_name ) + , ("fname" , "new" ) + , ("decl" , tmplFunToDecl b t f ) + , ("defn" , tmplFunToDef b t f ) ] + TFun {..} -> [ ("tname" , tclass_name ) + , ("fname" , tfun_name ) + , ("decl" , tmplFunToDecl b t f ) + , ("defn" , tmplFunToDef b t f ) ] + TFunDelete -> [ ("tname" , tclass_name ) + , ("fname" , "delete" ) + , ("decl" , tmplFunToDecl b t f ) + , ("defn" , tmplFunToDef b t f ) ] + +genTmplClassCpp :: Bool -- ^ is for simple type + -> TemplateClass + -> [TemplateFunction] + -> String +genTmplClassCpp b TmplCls {..} fs = subst tmpl ctxt + where + tmpl = "#define ${tname}_instance${suffix}(Type) \\\n\ + \$macro\n" + suffix = if b then "_s" else "" + ctxt = context [ ("tname" , tclass_name ) + , ("suffix" , suffix ) + , ("macro" , macro ) ] + tname = tclass_name + + macro1 TFun {..} = " " <> tname<> "_" <> tfun_name <> suffix <> "(Type) \\" + + macro1 TFunNew {..} = " " <> tname<> "_new(Type) \\" + macro1 TFunDelete = " " <> tname<> "_delete(Type) \\" + macro = intercalateWith connRet macro1 fs + 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,2015 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -14,34 +14,35 @@ module FFICXX.Generate.Code.Dependency where -import Control.Applicative -import Data.Function (on) +import Data.Function ( on ) +import qualified Data.HashMap.Strict as HM import Data.List import Data.Maybe -import qualified Data.HashMap.Strict as HM +import Data.Monoid ( (<>) ) import System.FilePath -- import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface -- | mkPkgHeaderFileName ::Class -> HeaderName mkPkgHeaderFileName c = - HdrName ((cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "h") + HdrName ((cabal_cheaderprefix.class_cabal) c <> class_name c <.> "h") -- | mkPkgCppFileName ::Class -> String mkPkgCppFileName c = - (cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "cpp" + (cabal_cheaderprefix.class_cabal) c <> class_name c <.> "cpp" -- | 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) ++ map HdrName extheaders + extheaders = nub . map ((<>"Type.h") . cabal_pkgname . class_cabal) $ extclasses + in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders @@ -54,23 +55,26 @@ mkCIH :: (Class->([Namespace],[HeaderName])) -- ^ (mk namespace and include headers) -> Class -> ClassImportHeader -mkCIH mkNSandIncHdrs c = let r = ClassImportHeader c - (mkPkgHeaderFileName c) - ((fst . mkNSandIncHdrs) c) - (mkPkgCppFileName c) - (mkPkgIncludeHeadersInH c) - (mkPkgIncludeHeadersInCPP c) - ((snd . mkNSandIncHdrs) c) - in r +mkCIH mkNSandIncHdrs c = ClassImportHeader c + (mkPkgHeaderFileName c) + ((fst . mkNSandIncHdrs) c) + (mkPkgCppFileName c) + (mkPkgIncludeHeadersInH c) + (mkPkgIncludeHeadersInCPP c) + ((snd . mkNSandIncHdrs) c) -- | extractClassFromType :: Types -> Maybe Class -extractClassFromType Void = Nothing -extractClassFromType SelfType = Nothing -extractClassFromType (CT _ _) = Nothing -extractClassFromType (CPT (CPTClass c) _) = Just c -extractClassFromType (CPT (CPTClassRef c) _) = Just c +extractClassFromType Void = Nothing +extractClassFromType SelfType = Nothing +extractClassFromType (CT _ _) = Nothing +extractClassFromType (CPT (CPTClass c) _) = Just c +extractClassFromType (CPT (CPTClassRef c) _) = Just c +extractClassFromType (CPT (CPTClassCopy c) _) = Just c +extractClassFromType (TemplateApp _ _ _) = Nothing +extractClassFromType (TemplateType _) = Nothing +extractClassFromType (TemplateParam _) = Nothing -- | class dependency for a given function @@ -112,7 +116,7 @@ pkgname = (cabal_pkgname . class_cabal) c extclasses = (filter (\x-> x /= c && ((/= pkgname) . cabal_pkgname . class_cabal) x) . concatMap (argumentDependency.extractClassDep)) fs parents = class_parents c - in nub (parents ++ extclasses) + in nub (parents <> extclasses) -- | @@ -128,14 +132,14 @@ let fs = class_funcs c in nub . filter (/= c) $ mapMaybe (returnDependency.extractClassDep) fs - ++ concatMap (argumentDependency.extractClassDep) fs - ++ (class_parents c) + <> concatMap (argumentDependency.extractClassDep) fs + <> (class_parents c) -- | mkModuleDepFFI4One :: Class -> [Class] mkModuleDepFFI4One c = let fs = class_funcs c - in (++) <$> mapMaybe (returnDependency.extractClassDep) + in (<>) <$> mapMaybe (returnDependency.extractClassDep) <*> concatMap (argumentDependency.extractClassDep) $ fs @@ -143,50 +147,52 @@ mkModuleDepFFI :: Class -> [Class] mkModuleDepFFI c = let ps = class_allparents c - alldeps' = (concatMap mkModuleDepFFI4One ps) ++ mkModuleDepFFI4One c - alldeps = nub (filter (/= c) alldeps') - in alldeps - + alldeps' = (concatMap mkModuleDepFFI4One ps) <> mkModuleDepFFI4One c + in nub (filter (/= c) alldeps') mkClassModule :: (Class->([Namespace],[HeaderName])) + -> [(String,[String])] -> Class -> ClassModule -mkClassModule mkincheaders c = - let r = (ClassModule <$> getClassModuleBase - <*> pure - <*> return . mkCIH mkincheaders - <*> highs_nonsource - <*> raws - <*> highs_source - <*> ffis - ) c - in r - - where highs_nonsource = map getClassModuleBase . mkModuleDepHighNonSource - raws = map getClassModuleBase . mkModuleDepRaw - highs_source = map getClassModuleBase . mkModuleDepHighSource - ffis = map getClassModuleBase . mkModuleDepFFI +mkClassModule mkincheaders extra c = + ClassModule (getClassModuleBase c) [c] (map (mkCIH mkincheaders) [c]) highs_nonsource + raws highs_source ffis extraimports + where highs_nonsource = (map getClassModuleBase . mkModuleDepHighNonSource) c + raws = (map getClassModuleBase . mkModuleDepRaw) c + highs_source = (map getClassModuleBase . mkModuleDepHighSource) c + ffis = (map getClassModuleBase . mkModuleDepFFI) c + extraimports = fromMaybe [] (lookup (class_name c) extra) + + 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) = - let ms = map (mkClassModule mkNSandIncHdrs) cs + +mkTCM :: (TemplateClass,HeaderName) -> TemplateClassModule +mkTCM (t,hdr) = TCM (getTClassModuleBase t) [t] [TCIH t hdr] + + +mkPackageConfig + :: (String,Class->([Namespace],[HeaderName])) -- ^ (package name,mkIncludeHeaders) + -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])]) + -> PackageConfig +mkPackageConfig (pkgname,mkNS_IncHdrs) (cs,fs,ts,extra) = + let ms = map (mkClassModule mkNS_IncHdrs extra) cs cmpfunc x y = class_name (cihClass x) == class_name (cihClass y) cihs = nubBy cmpfunc (concatMap cmCIH ms) -- for toplevel tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs tl_cs2 = mapMaybe (returnDependency . extractClassDepForTopLevelFunction) fs - tl_cs = nubBy ((==) `on` class_name) (tl_cs1 ++ tl_cs2) + tl_cs = nubBy ((==) `on` class_name) (tl_cs1 <> tl_cs2) tl_cihs = catMaybes $ foldr (\c acc-> (find (\x -> (class_name . cihClass) x == class_name c) cihs):acc) [] tl_cs -- - tih = TopLevelImportHeader (pkgname ++ "TopLevel") tl_cihs fs - in (ms,cihs,tih) + tih = TopLevelImportHeader (pkgname <> "TopLevel") tl_cihs fs + tcms = map mkTCM ts + tcihs = concatMap tcmTCIH tcms + in PkgConfig ms cihs tih tcms tcihs mkHSBOOTCandidateList :: [ClassModule] -> [String] 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 @@ -1,9 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFFI --- Copyright : (c) 2011-2013,2015 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -14,97 +15,50 @@ module FFICXX.Generate.Code.HsFFI where -import Data.Char (toLower) -import System.FilePath ((<.>)) +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Monoid ( (<>) ) +import Language.Haskell.Exts.Syntax ( Decl(..) ) +import System.FilePath ((<.>)) -- -import FFICXX.Generate.Util -import FFICXX.Generate.Type.Class -import FFICXX.Generate.Type.PackageInterface +import FFICXX.Generate.Util +import FFICXX.Generate.Util.HaskellSrcExts +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Module +import FFICXX.Generate.Type.PackageInterface -genHsFFI :: ClassImportHeader -> String +genHsFFI :: ClassImportHeader -> [Decl] genHsFFI header = let c = cihClass header h = cihSelfHeader header allfns = concatMap (virtualFuncs . class_funcs) (class_allparents c) - ++ (class_funcs c) - in intercalateWith connRet2 (hsFFIClassFunc h c) allfns - -genAllHsFFI :: [ClassImportHeader] -> String -genAllHsFFI = intercalateWith connRet2 genHsFFI + <> (class_funcs c) + in mapMaybe (hsFFIClassFunc h c) allfns -------- --- | this template will be deprecated -ffistub :: String -ffistub = "foreign import ccall \"$headerfilename$ $classname$_$funcname$\" $hsfuncname$ \n :: $hsargs$" - --- | this template will be used. -ffiTemplate :: String -ffiTemplate = "foreign import ccall \"$headerfilename$ $funcname$\" $hsfuncname$ \n :: $hsargs$" - - -hsFFIClassFunc :: HeaderName -> Class -> Function -> String -hsFFIClassFunc headerfilename c f = if isAbstractClass c - then "" - else if (isNewFunc f || isStaticFunc f) - then render ffistub - [ ("headerfilename",(unHdrName headerfilename)) - , ("classname",class_name c) - , ("funcname", aliasedFuncName c f) - , ("hsfuncname",hscFuncName c f) - , ("hsargs", hsFuncTypNoSelf c f) ] - else render ffistub - [ ("headerfilename",(unHdrName headerfilename)) - , ("classname",class_name c) - , ("funcname", aliasedFuncName c f) - , ("hsfuncname",hscFuncName c f) - , ("hsargs", hsFuncTyp c f) ] - +hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe Decl +hsFFIClassFunc headerfilename c f = + if isAbstractClass c + then Nothing + else let hfile = unHdrName headerfilename + cname = class_name c <> "_" <> aliasedFuncName c f + typ = if (isNewFunc f || isStaticFunc f) + then hsFFIFuncTyp (Just (NoSelf,c)) (genericFuncArgs f, genericFuncRet f) + else hsFFIFuncTyp (Just (Self,c) ) (genericFuncArgs f, genericFuncRet f) + in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ) + ---------------------------- -- for top level function -- ---------------------------- -genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> String -genTopLevelFuncFFI header tfn = - case tfn of - TopLevelFunction {..} -> - let fname = maybe toplevelfunc_name id toplevelfunc_alias - (x:xs) = fname - headerfilename = tihHeaderFileName header <.> "h" - hfname = toLower x : xs - cfname = "c_" ++ toLowers hfname - args = toplevelfunc_args - ret = toplevelfunc_ret - argstr = concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret - in render ffiTemplate - [ ("headerfilename",headerfilename) - , ("funcname", "TopLevel_" ++ fname) - , ("hsfuncname",cfname) - , ("hsargs", argstr) ] - TopLevelVariable {..} -> - let fname = maybe toplevelvar_name id toplevelvar_alias - (x:xs) = fname - headerfilename = tihHeaderFileName header <.> "h" - hfname = toLower x : xs - cfname = "c_" ++ toLowers hfname - args = [] - ret = toplevelvar_ret - argstr = concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret - in render ffiTemplate - [ ("headerfilename",headerfilename) - , ("funcname", "TopLevel_" ++ fname) - , ("hsfuncname",cfname) - , ("hsargs", argstr) ] - - where hsargtype (CT ctype _) = hsCTypeName ctype - hsargtype (CPT x _) = hsCppTypeName x - hsargtype SelfType = "genTopLevelFuncFFI : no self for top level function " - hsargtype _ = error "undefined hsargtype" - - hsrettype Void = "IO ()" - hsrettype SelfType = "genTopLevelFuncFFI : no self for top level function " - hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype - hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x - +genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl +genTopLevelFuncFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ + where (fname,args,ret) = + case tfn of + TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) + TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) + hfilename = tihHeaderFileName header <.> "h" + cfname = "c_" <> toLowers fname + typ =hsFFIFuncTyp Nothing (args,ret) 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,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFrontEnd --- Copyright : (c) 2011-2013,2015 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -15,27 +16,36 @@ module FFICXX.Generate.Code.HsFrontEnd where -import Control.Monad.State -import Control.Monad.Reader -import Data.Char (toLower) -import Data.List -import qualified Data.Map as M -import Data.Maybe -import System.FilePath ((<.>)) +import Control.Monad.State +import Control.Monad.Reader +import Data.List +import Data.Monoid ( (<>) ) +import Language.Haskell.Exts.Syntax ( Asst(..), Binds(..), Boxed(..), Bracket(..) + , ClassDecl(..), DataOrNew(..), Decl(..) + , Exp(..), ExportSpec(..) + , ImportDecl(..), InstDecl(..), Literal(..) + , Name(..), Namespace(..), Pat(..) + , QualConDecl(..), Stmt(..) + , Type(..), TyVarBind (..) + ) +import Language.Haskell.Exts.SrcLoc ( noLoc ) +import System.FilePath ((<.>)) -- -import FFICXX.Generate.Type.Class -import FFICXX.Generate.Type.Annotate -import FFICXX.Generate.Type.Module -import FFICXX.Generate.Util +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Annotate +import FFICXX.Generate.Type.Module +import FFICXX.Generate.Util +import FFICXX.Generate.Util.HaskellSrcExts + mkComment :: Int -> String -> String mkComment indent str | (not.null) str = let str_lines = lines str indentspace = replicate indent ' ' commented_lines = - (indentspace ++ "-- | "++head str_lines) : map (\x->indentspace ++ "-- "++x) (tail str_lines) + (indentspace <> "-- | "<>head str_lines) : map (\x->indentspace <> "-- "<>x) (tail str_lines) in unlines commented_lines | otherwise = str @@ -44,538 +54,347 @@ | (not.null) str = let str_lines = lines str commented_lines = - ("-- ^ "++head str_lines) : map (\x->"-- "++x) (tail str_lines) + ("-- ^ "<>head str_lines) : map (\x->"-- "<>x) (tail str_lines) in unlines commented_lines | otherwise = str - ----------------- --- | -hsModuleDeclTmpl :: String -hsModuleDeclTmpl = "module $moduleName$ $moduleExp$ where" - --- | -genModuleDecl :: Module -> Reader AnnotateMap String -genModuleDecl m = do - let modheader = render hsModuleDeclTmpl [ ("moduleName", module_name m) - , ("moduleExp", mkModuleExports m) ] - return (modheader) - - ----------------- --- | -classprefix :: Class -> String -classprefix c = let ps = (map typeclassName . class_parents) c - in if null ps - then "" - else "(" ++ intercalate "," (map (++ " a") ps) ++ ") => " - --- | -hsClassDeclHeaderTmpl :: String -hsClassDeclHeaderTmpl = "$classann$\nclass $constraint$$classname$ a where" - -genHsFrontDecl :: Class -> Reader AnnotateMap String -genHsFrontDecl c = do - amap <- ask - let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap - let header = render hsClassDeclHeaderTmpl [ ("classname", typeclassName c ) - , ("constraint", classprefix c) - , ("classann", mkComment 0 cann) ] - bodyline func = - let fname = hsFuncName c func - mann = maybe "" id $ M.lookup (PkgMethod,fname) amap - in render hsClassDeclFuncTmpl - [ ("funcname", hsFuncName c func) - , ("args" , prefixstr func ++ argstr func ) - , ("funcann", mkComment 4 mann) - ] - prefixstr func = - let prefixlst = (snd . mkHsFuncArgType . genericFuncArgs) func - ++ (snd . mkHsFuncRetType . genericFuncRet ) func - in if null prefixlst - then "" - else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => " - - argstr func = intercalateWith connArrow id $ - [ "a" ] - ++ fst (mkHsFuncArgType (genericFuncArgs func)) - ++ ["IO " ++ (fst . mkHsFuncRetType . genericFuncRet) func] - bodylines = map bodyline . virtualFuncs - $ (class_funcs c) - return $ intercalateWith connRet id (header : bodylines) - - - -genAllHsFrontDecl :: [Class] -> Reader AnnotateMap String -genAllHsFrontDecl = intercalateWithM connRet2 genHsFrontDecl +genHsFrontDecl :: Class -> Reader AnnotateMap Decl +genHsFrontDecl c = do + -- for the time being, let's ignore annotation. + -- amap <- ask + -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap + let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body + sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) + body = map (ClsDecl . sigdecl) . virtualFuncs . class_funcs $ c + return cdecl ------------------- - -genHsFrontInst :: Class -> Class -> String +genHsFrontInst :: Class -> Class -> [Decl] genHsFrontInst parent child | (not.isAbstractClass) child = - let headline = "instance " ++ typeclassName parent ++ " " ++ (fst.hsClassName) child ++ " where" - defline func = " " ++ hsFuncName child func ++ " = " ++ hsFuncXformer func ++ " " ++ hscFuncName child func - deflines = (map defline) . virtualFuncs . class_funcs $ parent - - in intercalateWith connRet id (headline : deflines) - | otherwise = "" + let idecl = mkInstance [] (typeclassName parent) [convertCpp2HS (Just child) SelfType] body + defn f = mkBind1 (hsFuncName child f) [] rhs Nothing + where rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f)) + body = map (InsDecl . defn) . virtualFuncs . class_funcs $ parent + in [idecl] + | otherwise = [] ---------------------- -hsClassInstExistCommonTmpl :: String -hsClassInstExistCommonTmpl = "instance FPtr (Exist $highname$) where\n type Raw (Exist $highname$) = $rawname$\n get_fptr ($existConstructor$ obj) = castForeignPtr (get_fptr obj)\n cast_fptr_to_obj fptr = $existConstructor$ (cast_fptr_to_obj (fptr :: ForeignPtr $rawname$) :: $highname$)" - - -genHsFrontInstExistCommon :: Class -> String -genHsFrontInstExistCommon c = render hsClassInstExistCommonTmpl tmplName - where (highname,rawname) = hsClassName c - iname = typeclassName c - ename = existConstructorName c - tmplName = [ ("rawname",rawname) - , ("highname",highname) - , ("interfacename",iname) - , ("existConstructor",ename) - ] - -genAllHsFrontInstExistCommon :: [Class] -> String -genAllHsFrontInstExistCommon cs = intercalateWith connRet2 genHsFrontInstExistCommon cs - -------------------- - -hsClassInstExistVirtualTmpl :: String -hsClassInstExistVirtualTmpl = "instance $Iparent$ (Exist $child$) where\n$method$" - -hsClassInstExistVirtualMethodNoSelfTmpl :: String -hsClassInstExistVirtualMethodNoSelfTmpl = " $methodname$ ($exist$ x) = $methodname$ x" - -hsClassInstExistVirtualMethodSelfTmpl :: String -hsClassInstExistVirtualMethodSelfTmpl = " $methodname$ ($exist$ x) $args$ = return . $exist$ =<< $methodname$ x $args$" - - -genHsFrontInstExistVirtual :: Class -> Class -> String -genHsFrontInstExistVirtual p c = render hsClassInstExistVirtualTmpl tmplName - where methodstr = intercalateWith connRet (genHsFrontInstExistVirtualMethod p c) - (virtualFuncs.class_funcs $ p) - tmplName = [ ("Iparent",typeclassName p) - , ("child", (fst.hsClassName) c) - , ("method", methodstr ) - ] - -genHsFrontInstExistVirtualMethod :: Class -> Class -> Function -> String -genHsFrontInstExistVirtualMethod p c f = - case f of - Constructor _ _ -> error "error in genHsFrontInstExistVirtualMethod" - Destructor _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName - _ -> case func_ret f of - SelfType -> render hsClassInstExistVirtualMethodSelfTmpl (tmplName++args) - _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName - where tmplName = [ ("methodname", hsFuncName p f) - , ("exist", existConstructorName c) ] - args = [ ("args", intercalate " " (take (length (func_args f)) (map (\x -> 'a':(show x)) ([1..] :: [Int]) )))] - -genAllHsFrontInstExistVirtual :: [Class] -> DaughterMap -> String -genAllHsFrontInstExistVirtual cs _dmap = intercalateWith connRet2 allinstances cs - where allinstances c = - let ps = c : class_allparents c - in intercalateWith connRet2 (\p->genHsFrontInstExistVirtual p c) ps - - --------------------- genHsFrontInstNew :: Class -- ^ only concrete class - -> Reader AnnotateMap (Maybe String) + -> Reader AnnotateMap [Decl] genHsFrontInstNew c = do - amap <- ask - if null newfuncs - then return Nothing - else do - let newfunc = head newfuncs - cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap - newfuncann = mkComment 0 cann - newlinehead = constructorName c ++ " :: " ++ argstr newfunc - newlinebody = constructorName c ++ " = " - ++ hsFuncXformer newfunc ++ " " - ++ hscFuncName c newfunc - argstr func = intercalateWith connArrow id $ - map (ctypToHsTyp (Just c) . fst) (genericFuncArgs func) - ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) func] - newline = newfuncann ++ "\n" ++ newlinehead ++ "\n" ++ newlinebody - return (Just newline) - where newfuncs = filter isNewFunc (class_funcs c) + -- amap <- ask + let fs = filter isNewFunc (class_funcs c) + return . flip concatMap fs $ \f -> + let + -- for the time being, let's ignore annotation. + -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap + -- newfuncann = mkComment 0 cann + rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (constructorName c) (functionSignature c f) [] rhs Nothing -genAllHsFrontInstNew :: [Class] -- ^ only concrete class - -> Reader AnnotateMap String -genAllHsFrontInstNew = liftM (intercalate "\n\n") . liftM catMaybes . mapM genHsFrontInstNew - -genHsFrontInstNonVirtual :: Class -> Maybe String -genHsFrontInstNonVirtual c - | (not.null) nonvirtualFuncs = - let header f = (aliasedFuncName c f) ++ " :: " ++ argstr f - body f = (aliasedFuncName c f) ++ " = " ++ hsFuncXformer f ++ " " ++ hscFuncName c f - argstr func = intercalateWith connArrow id $ - [(fst.hsClassName) c] - ++ map (ctypToHsTyp (Just c) . fst) (genericFuncArgs func) - ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) func] - in Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) nonvirtualFuncs - | otherwise = Nothing +genHsFrontInstNonVirtual :: Class -> [Decl] +genHsFrontInstNonVirtual c = + flip concatMap nonvirtualFuncs $ \f -> + let rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) -genAllHsFrontInstNonVirtual :: [Class] -> String -genAllHsFrontInstNonVirtual = intercalate "\n\n" . map fromJust . filter isJust . map genHsFrontInstNonVirtual - ----- -genHsFrontInstStatic :: Class -> Maybe String -genHsFrontInstStatic c - | (not.null) fs = - let header f = (aliasedFuncName c f) ++ " :: " ++ argstr f - body f = (aliasedFuncName c f) ++ " = " ++ hsFuncXformer f ++ " " ++ hscFuncName c f - argstr f = intercalateWith connArrow id $ - map (ctypToHsTyp (Just c) . fst) (genericFuncArgs f) - ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) f] - in Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) fs - | otherwise = Nothing - where fs = staticFuncs (class_funcs c) +genHsFrontInstStatic :: Class -> [Decl] +genHsFrontInstStatic c = + flip concatMap (staticFuncs (class_funcs c)) $ \f -> + let rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing ----- -genHsFrontInstCastable :: Class -> String +castBody :: [InstDecl] +castBody = + [ InsDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (App (mkVar "f") (App (mkVar "castPtr") (App (mkVar "get_fptr") (mkVar "x")))) Nothing) + , InsDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (App (mkVar "f") (App (mkVar "cast_fptr_to_obj") (App (mkVar "castPtr") (mkVar "x")))) Nothing) + ] + +genHsFrontInstCastable :: Class -> Maybe Decl genHsFrontInstCastable c | (not.isAbstractClass) c = let iname = typeclassName c (_,rname) = hsClassName c - in render hsInterfaceCastableInstanceTmpl - [("interfaceName",iname),("rawClassName",rname)] - | otherwise = "" - -genAllHsFrontInstCastable :: [Class] -> String -genAllHsFrontInstCastable = - intercalateWith connRet2 genHsFrontInstCastable + a = mkTVar "a" + ctxt = [ ClassA (unqual iname) [a], ClassA (unqual "FPtr") [a] ] + in Just (mkInstance ctxt "Castable" [a,TyApp tyPtr (tycon rname)] castBody) + | otherwise = Nothing -genHsFrontInstCastableSelf :: Class -> String +genHsFrontInstCastableSelf :: Class -> Maybe Decl genHsFrontInstCastableSelf c | (not.isAbstractClass) c = let (cname,rname) = hsClassName c - in render hsInterfaceCastableInstanceSelfTmpl - [("className",cname) - ,("rawClassName",rname)] - | otherwise = "" + in Just (mkInstance [] "Castable" [tycon cname, TyApp tyPtr (tycon rname)] castBody) + | otherwise = Nothing -------------------------- -rawToHighDecl :: String -rawToHighDecl = "data $rawname$\nnewtype $highname$ = $highname$ (ForeignPtr $rawname$) deriving (Eq, Ord, Show)" - -rawToHighInstance :: String -rawToHighInstance = "instance FPtr $highname$ where\n type Raw $highname$ = $rawname$\n get_fptr ($highname$ fptr) = fptr\n cast_fptr_to_obj = $highname$" - - -existableInstance :: String -existableInstance = "instance Existable $highname$ where\n data Exist $highname$ = forall a. (FPtr a, $interfacename$ a) => $existConstructor$ a" - - -hsClassRawType :: Class -> String -hsClassRawType c = - let decl = render rawToHighDecl tmplName - inst1 = render rawToHighInstance tmplName - in decl `connRet` inst1 - where (highname,rawname) = hsClassName c - iname = typeclassName c - -- ename = existConstructorName c - tmplName = [ ("rawname",rawname) - , ("highname",highname) - , ("interfacename",iname) - ] - -hsClassExistType :: Class -> String -hsClassExistType c = render existableInstance tmplName - where (highname,_rawname) = hsClassName c - iname = typeclassName c - ename = existConstructorName c - tmplName = [ ("existConstructor",ename) - , ("highname",highname) - , ("interfacename",iname) - ] - -hsClassDeclFuncTmpl :: String -hsClassDeclFuncTmpl = "$funcann$\n $funcname$ :: $args$ " - - -hsArgs :: Class -> Args -> String -hsArgs c = intercalateWith connArrow (ctypToHsTyp (Just c) . fst) - -mkHsFuncArgType :: Args -> ([String],[String]) -mkHsFuncArgType lst = - let (args,st) = runState (mapM mkFuncArgTypeWorker lst) ([],(0 :: Int)) - in (args,fst st) - where mkFuncArgTypeWorker (typ,_var) = - case typ of - SelfType -> return "a" - CT _ _ -> return $ ctypToHsTyp Nothing typ - CPT (CPTClass c') _ -> do - (prefix,n) <- get - let cname = (fst.hsClassName) c' - iname = typeclassNameFromStr cname - newname = 'c' : show n - newprefix1 = iname ++ " " ++ newname - newprefix2 = "FPtr " ++ newname - put (newprefix1:newprefix2:prefix,n+1) - return newname - CPT (CPTClassRef c') _ -> do - (prefix,n) <- get - let cname = (fst.hsClassName) c' - iname = typeclassNameFromStr cname - newname = 'c' : show n - newprefix1 = iname ++ " " ++ newname - newprefix2 = "FPtr " ++ newname - put (newprefix1:newprefix2:prefix,n+1) - return newname - _ -> error ("No such c type : " ++ show typ) - -mkHsFuncRetType :: Types -> (String,[String]) -mkHsFuncRetType rtyp = - case rtyp of - SelfType -> ("a",[]) - CPT (CPTClass c') _ -> (cname,[]) where cname = (fst.hsClassName) c' - CPT (CPTClassRef c') _ -> (cname,[]) where cname = (fst.hsClassName) c' - _ -> (ctypToHsTyp Nothing rtyp,[]) - +hsClassRawType :: Class -> [Decl] +hsClassRawType c = + [ mkData rawname [] [] [] + , mkNewtype highname [] + [ QualConDecl noLoc [] [] + (conDecl highname [TyApp tyPtr rawtype]) + ] + derivs + , mkInstance [] "FPtr" [hightype] + [ InsType noLoc (TyApp (tycon "Raw") hightype) rawtype + , InsDecl (mkBind1 "get_fptr" [PApp (unqual highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing) + , InsDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing) + ] ----------- - -hsInterfaceCastableInstanceTmpl :: String -hsInterfaceCastableInstanceTmpl = - "instance ($interfaceName$ a, FPtr a) => Castable a (Ptr $rawClassName$) where\n cast = unsafeForeignPtrToPtr . castForeignPtr . get_fptr\n uncast = cast_fptr_to_obj . castForeignPtr . unsafePerformIO . newForeignPtr_ \n" - -hsInterfaceCastableInstanceSelfTmpl :: String -hsInterfaceCastableInstanceSelfTmpl = - "instance Castable $className$ (Ptr $rawClassName$) where\n cast = unsafeForeignPtrToPtr . castForeignPtr . get_fptr\n uncast = cast_fptr_to_obj . castForeignPtr . unsafePerformIO . newForeignPtr_ \n" - - ----------- - -hsExistentialGADTBodyTmpl :: String -hsExistentialGADTBodyTmpl = " GADT$mother$$daughter$ :: $daughter$ -> GADTType $mother$ $daughter$" + ] + where (highname,rawname) = hsClassName c + hightype = tycon highname + rawtype = tycon rawname + derivs = [(unqual "Eq",[]),(unqual "Ord",[]),(unqual "Show",[])] -hsExistentialCastBodyTmpl :: String -hsExistentialCastBodyTmpl = " \"$daughter$\" -> case obj of\n $mother$ fptr -> let obj' = $daughter$ (castForeignPtr fptr :: ForeignPtr Raw$daughter$)\n in return . EGADT$mother$ . GADT$mother$$daughter$ \\$ obj'" - ------------ -- upcast -- ------------ -genHsFrontUpcastClass :: Class -> Reader AnnotateMap String -genHsFrontUpcastClass c = do - -- amap <- ask - let (highname,rawname) = hsClassName c - upcaststr = render hsUpcastClassTmpl [ ("classname", highname) - , ("ifacename", typeclassName c) - , ("rawclassname", rawname) - , ("space", replicate (length highname+11) ' ' ) ] - return upcaststr - -genAllHsFrontUpcastClass :: [Class] -> Reader AnnotateMap String -genAllHsFrontUpcastClass = intercalateWithM connRet2 genHsFrontUpcastClass - - -hsUpcastClassTmpl :: String -hsUpcastClassTmpl = "upcast$classname$ :: (FPtr a, $ifacename$ a) => a -> $classname$\nupcast$classname$ h = let fh = get_fptr h\n$space$ fh2 :: ForeignPtr $rawclassname$ = castForeignPtr fh\n$space$in cast_fptr_to_obj fh2" +genHsFrontUpcastClass :: Class -> [Decl] +genHsFrontUpcastClass c = mkFun ("upcast"<>highname) typ [mkPVar "h"] rhs Nothing + where (highname,rawname) = hsClassName c + hightype = tycon highname + rawtype = tycon rawname + iname = typeclassName c + a_bind = UnkindedVar (Ident "a") + a_tvar = mkTVar "a" + typ = TyForall (Just [a_bind]) + [ClassA (unqual "FPtr") [a_tvar], ClassA (unqual iname) [a_tvar]] + (TyFun a_tvar hightype) + rhs = Let (BDecls + [ pbind (mkPVar "fh") (App (mkVar "get_fptr") (mkVar "h")) Nothing + , pbind (mkPVarSig "fh2" (TyApp tyPtr rawtype)) + (App (mkVar "castPtr") (mkVar "fh")) Nothing + ] + ) + (mkVar "cast_fptr_to_obj" `App` mkVar "fh2") -------------- -- downcast -- -------------- -genHsFrontDowncastClass :: Class -> Reader AnnotateMap String -genHsFrontDowncastClass c = do - let (highname,rawname) = hsClassName c - downcaststr = render hsDowncastClassTmpl [ ("classname", highname) - , ("ifacename", typeclassName c) - , ("rawclassname", rawname) - , ("space", replicate (length highname+13) ' ' ) ] - return downcaststr +genHsFrontDowncastClass :: Class -> [Decl] +genHsFrontDowncastClass c = mkFun ("downcast"<>highname) typ [mkPVar "h"] rhs Nothing + where (highname,_rawname) = hsClassName c + hightype = tycon highname + iname = typeclassName c + a_bind = UnkindedVar (Ident "a") + a_tvar = mkTVar "a" + typ = TyForall (Just [a_bind]) + [ClassA (unqual "FPtr") [a_tvar], ClassA (unqual iname) [a_tvar]] + (TyFun hightype a_tvar) + rhs = Let (BDecls + [ pbind (mkPVar "fh") (App (mkVar "get_fptr") (mkVar "h")) Nothing + , pbind (mkPVar "fh2") (App (mkVar "castPtr") (mkVar "fh")) Nothing + ] + ) + (mkVar "cast_fptr_to_obj" `App` mkVar "fh2") -genAllHsFrontDowncastClass :: [Class] -> Reader AnnotateMap String -genAllHsFrontDowncastClass = intercalateWithM connRet2 genHsFrontDowncastClass +------------------------ +-- Top Level Function -- +------------------------ -hsDowncastClassTmpl :: String -hsDowncastClassTmpl = "downcast$classname$ :: (FPtr a, $ifacename$ a) => $classname$ -> a \ndowncast$classname$ h = let fh = get_fptr h\n$space$ fh2 = castForeignPtr fh\n$space$in cast_fptr_to_obj fh2" +genTopLevelFuncDef :: TopLevelFunction -> [Decl] +genTopLevelFuncDef f@TopLevelFunction {..} = + let fname = hsFrontNameForTopLevelFunction f + (typs,ctxts) = extractArgRetTypes Nothing False (toplevelfunc_args,toplevelfunc_ret) + -- rtyp = (tycon . ctypToHsTyp Nothing) toplevelfunc_ret + sig = TyForall Nothing ctxts (foldr1 TyFun typs) + xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull" + cfname = "c_" <> toLowers fname + rhs = App (mkVar xformerstr) (mkVar cfname) + + in mkFun fname sig [] rhs Nothing +genTopLevelFuncDef v@TopLevelVariable {..} = + let fname = hsFrontNameForTopLevelFunction v + cfname = "c_" <> toLowers fname + rtyp = (tycon . ctypToHsTyp Nothing) toplevelvar_ret + sig = TyApp (tycon "IO") rtyp + rhs = App (mkVar "xformnull") (mkVar cfname) + + in mkFun fname sig [] rhs Nothing + ------------ -- Export -- ------------ -genExport :: Class -> String +genExport :: Class -> [ExportSpec] genExport c = - let methodstr = if null . (filter isVirtualFunc) $ (class_funcs c) - then "" - else "(..)" + let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) + then EAbs NoNamespace (unqual n) + else EThingAll (unqual n) in if isAbstractClass c - then " " ++ typeclassName c ++ methodstr - else " " ++ (fst.hsClassName) c ++ "(..)\n , " - ++ typeclassName c ++ methodstr - ++ "\n , upcast" ++ (fst.hsClassName) c - ++ "\n , downcast" ++ (fst.hsClassName) c - ++ "\n" ++ genExportConstructorAndNonvirtual c - ++ "\n" ++ genExportStatic c + then [ espec (typeclassName c) ] + else [ EThingAll (unqual ((fst.hsClassName) c)) + , espec (typeclassName c) + , EVar (unqual ("upcast" <> (fst.hsClassName) c)) + , EVar (unqual ("downcast" <> (fst.hsClassName) c)) ] + <> genExportConstructorAndNonvirtual c + <> genExportStatic c -- | constructor and non-virtual function -genExportConstructorAndNonvirtual :: Class -> String -genExportConstructorAndNonvirtual c = - intercalateWith connRet (\x->indent++", "++x) fns - where indent = replicate 2 ' ' - fs = class_funcs c +genExportConstructorAndNonvirtual :: Class -> [ExportSpec] +genExportConstructorAndNonvirtual c = map (EVar . unqual) fns + where fs = class_funcs c fns = map (aliasedFuncName c) (constructorFuncs fs - ++ nonVirtualNotNewFuncs fs) + <> nonVirtualNotNewFuncs fs) -- | staic function export list -genExportStatic :: Class -> String -genExportStatic c = - intercalateWith connRet (\x->indent++", "++x) fns - where indent = replicate 2 ' ' - fs = class_funcs c +genExportStatic :: Class -> [ExportSpec] +genExportStatic c = map (EVar . unqual) fns + where fs = class_funcs c fns = map (aliasedFuncName c) (staticFuncs fs) - - - -genExportList :: [Class] -> String -genExportList = concatMap genExport - -importOneClass :: String -> String -> String -importOneClass mname typ = "import " ++ mname <.> typ - -importSOURCEOneClass :: String -> String -> String -importSOURCEOneClass mname typ = "import {-# SOURCE #-} " ++ mname <.> typ - - -genImportInModule :: [Class] -> String -genImportInModule cs = - let genImportOneClass c = - let n = getClassModuleBase c - in intercalateWith connRet (importOneClass n) $ - ["RawType", "Interface", "Implementation"] - in intercalate "\n" (map genImportOneClass cs) +genExtraImport :: ClassModule -> [ImportDecl] +genExtraImport cm = map mkImport (cmExtraImport cm) -genImportInFFI :: ClassModule -> String -genImportInFFI m = - let modlst = cmImportedModulesForFFI m - in intercalateWith connRet (\x->importOneClass x "RawType") modlst +genImportInModule :: [Class] -> [ImportDecl] +genImportInModule = concatMap (\x -> map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"]) +genImportInFFI :: ClassModule -> [ImportDecl] +genImportInFFI = map (\x->mkImport (x <.> "RawType")) . cmImportedModulesForFFI -genImportInInterface :: ClassModule -> String +genImportInInterface :: ClassModule -> [ImportDecl] genImportInInterface m = let modlstraw = cmImportedModulesRaw m modlstparent = cmImportedModulesHighNonSource m modlsthigh = cmImportedModulesHighSource m - getImportOneClassRaw mname = - intercalateWith connRet (importOneClass mname) ["RawType"] - getImportOneClassHigh mname = - intercalateWith connRet (importOneClass mname) ["Interface"] - getImportSOURCEOneClassHigh mname = - intercalateWith connRet (importSOURCEOneClass mname) ["Interface"] - in importOneClass (cmModule m) "RawType" - `connRet` - intercalateWith connRet getImportOneClassRaw modlstraw - `connRet` - intercalateWith connRet getImportOneClassHigh modlstparent - `connRet` - "---- ============ ----" - `connRet` - intercalateWith connRet getImportSOURCEOneClassHigh modlsthigh + in [mkImport (cmModule m <.> "RawType")] + <> map (\x -> mkImport (x<.>"RawType")) modlstraw + <> map (\x -> mkImport (x<.>"Interface")) modlstparent + <> map (\x -> mkImportSrc (x<.>"Interface")) modlsthigh -- | -genImportInCast :: ClassModule -> String -genImportInCast m = - importOneClass (cmModule m) "RawType" - `connRet` - importOneClass (cmModule m) "Interface" +genImportInCast :: ClassModule -> [ImportDecl] +genImportInCast m = [ mkImport (cmModule m <.> "RawType") + , mkImport (cmModule m <.> "Interface") ] -- | -genImportInImplementation :: ClassModule -> String +genImportInImplementation :: ClassModule -> [ImportDecl] genImportInImplementation m = let modlstraw' = cmImportedModulesForFFI m modlsthigh = nub $ map getClassModuleBase $ concatMap class_allparents (cmClass m) modlstraw = filter (not.(flip elem modlsthigh)) modlstraw' - getImportOneClassRaw mname = - intercalateWith connRet (importOneClass mname) - ["RawType","Cast","Interface"] - getImportOneClassHigh mname = - intercalateWith connRet (importOneClass mname) - ["RawType","Cast","Interface"] - in importOneClass (cmModule m) "RawType" - `connRet` - importOneClass (cmModule m) "FFI" - `connRet` - importOneClass (cmModule m) "Interface" - `connRet` - importOneClass (cmModule m) "Cast" - `connRet` - intercalateWith connRet getImportOneClassRaw modlstraw - `connRet` - intercalateWith connRet getImportOneClassHigh modlsthigh + in [ mkImport (cmModule m <.> "RawType") + , mkImport (cmModule m <.> "FFI") + , mkImport (cmModule m <.> "Interface") + , mkImport (cmModule m <.> "Cast") ] + <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlstraw + <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlsthigh --- | -genImportInExistential :: DaughterMap -> ClassModule -> String -genImportInExistential dmap m = - let daughters = concat . catMaybes $ (map (flip M.lookup dmap . getClassModuleBase) (cmClass m)) - alldaughters' = nub . map getClassModuleBase $ daughters - -- alldaughters = filter ((&&) <$> (/= "TClass") <*> (/= "TObject")) alldaughters' - alldaughters = alldaughters' - getImportOneClass mname = - intercalateWith connRet (importOneClass mname) - ["RawType", "Cast", "Interface", "Implementation"] - in intercalateWith connRet getImportOneClass alldaughters + +genTmplInterface :: TemplateClass -> [Decl] +genTmplInterface t = + [ mkData rname [mkTBind tp] [] [] + , mkNewtype hname [mkTBind tp] + [ QualConDecl noLoc [] [] (conDecl hname [TyApp tyPtr rawtype]) ] [] + , mkClass [] (typeclassNameT t) [mkTBind tp] methods + , mkInstance [] "FPtr" [ hightype ] fptrbody + , mkInstance [] "Castable" [ hightype, TyApp tyPtr rawtype ] castBody + ] + where (hname,rname) = hsTemplateClassName t + tp = tclass_param t + fs = tclass_funcs t + rawtype = TyApp (tycon rname) (mkTVar tp) + hightype = TyApp (tycon hname) (mkTVar tp) + sigdecl f@TFun {..} = mkFunSig tfun_name (functionSignatureT t f) + sigdecl f@TFunNew {..} = mkFunSig ("new"<>tclass_name t) (functionSignatureT t f) + sigdecl f@TFunDelete = mkFunSig ("delete"<>tclass_name t) (functionSignatureT t f) + methods = map (ClsDecl . sigdecl) fs + fptrbody = [ InsType noLoc (TyApp (tycon "Raw") hightype) rawtype + , InsDecl (mkBind1 "get_fptr" [PApp (unqual hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing) + , InsDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing) + ] +genTmplImplementation :: TemplateClass -> [Decl] +genTmplImplementation t = concatMap gen (tclass_funcs t) + where + gen f = mkFun nh sig [p "nty", p "ncty"] rhs (Just binds) + where nh = case f of + TFun {..} -> "t_" <> tfun_name + TFunNew {..} -> "t_" <> "new" <> tclass_name t + TFunDelete -> "t_" <> "delete" <> tclass_name t + nc = case f of + TFun {..} -> tfun_name + TFunNew {..} -> "new" + TFunDelete -> "delete" + sig = tycon "Name" `TyFun` (tycon "String" `TyFun` tycon "ExpQ") + v = mkVar + p = mkPVar + tp = tclass_param t + prefix = tclass_name t + lit = Lit (String (prefix<>"_"<>nc<>"_")) + lam = Lambda noLoc [p "n"] ( lit `App` v "<>" `App` v "n") + rhs = App (v "mkTFunc") (Tuple Boxed [v "nty", v "ncty", lam, v "tyf"]) + sig' = functionSignatureTT t f + binds = BDecls [ mkBind1 "tyf" [mkPVar "n"] + (Let (BDecls [ pbind (p tp) (v "return" `App` (con "ConT" `App` v "n")) Nothing ]) + (BracketExp (TypeBracket sig'))) + Nothing + ] ------------------------- --- Top Level Function -- ------------------------- - -genTopLevelFuncDef :: TopLevelFunction -> String -genTopLevelFuncDef f@TopLevelFunction {..} = - let fname = hsFrontNameForTopLevelFunction f - cfname = "c_" ++ toLowers fname - args = toplevelfunc_args - ret = toplevelfunc_ret - xformerstr = let len = length args in if len > 0 then "xform" ++ show (len-1) else "xformnull" - prefixstr = - let prefixlst = (snd . mkHsFuncArgType) toplevelfunc_args - ++ (snd . mkHsFuncRetType) toplevelfunc_ret - in if null prefixlst - then "" - else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => " +genTmplInstance :: TemplateClass -> [TemplateFunction] -> [Decl] +genTmplInstance t fs = mkFun fname sig [p "n", p "ctyp"] rhs Nothing + where tname = tclass_name t + fname = "gen" <> tname <> "InstanceFor" + p = mkPVar + v = mkVar + l = Lit . String + sig = tycon "Name" `TyFun` (tycon "String" `TyFun` (TyApp (tycon "Q") (TyList (tycon "Dec")))) - argstr = intercalateWith connArrow id $ - (fst . mkHsFuncArgType) toplevelfunc_args - ++ ["IO " ++ (fst . mkHsFuncRetType) toplevelfunc_ret] - defstr = fname ++ " = " ++ xformerstr ++ " " ++ cfname - in fname ++ " :: " ++ prefixstr ++ argstr ++ "\n" ++ defstr -genTopLevelFuncDef v@TopLevelVariable {..} = - let fname = hsFrontNameForTopLevelFunction v - cfname = "c_" ++ toLowers fname - args = [] - ret = toplevelvar_ret - xformerstr = let len = length args in if len > 0 then "xform" ++ show (len-1) else "xformnull" - prefixstr = - let prefixlst = (snd . mkHsFuncRetType) toplevelvar_ret - in if null prefixlst - then "" - else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => " + nfs = zip ([1..] :: [Int]) fs + rhs = Do (map genstmt nfs <> [LetStmt (lststmt nfs), Qualifier retstmt]) - argstr = intercalateWith connArrow id $ ["IO " ++ (fst . mkHsFuncRetType) toplevelvar_ret] - defstr = fname ++ " = " ++ xformerstr ++ " " ++ cfname - in fname ++ " :: " ++ prefixstr ++ argstr ++ "\n" ++ defstr + genstmt (n,TFun {..}) = Generator noLoc (p ("f"<>show n)) + (v "mkMember" `App` l tfun_name + `App` v ("t_" <> tfun_name) + `App` v "n" + `App` v "ctyp" + ) + genstmt (n,TFunNew {..}) = Generator noLoc (p ("f"<>show n)) + (v "mkNew" `App` l ("new" <> tname) + `App` v ("t_new" <> tname) + `App` v "n" + `App` v "ctyp" + ) + genstmt (n,TFunDelete) = Generator noLoc (p ("f"<>show n)) + (v "mkDelete" `App` l ("delete"<>tname) + `App` v ("t_delete" <> tname) + `App` v "n" + `App` v "ctyp" + ) + lststmt lst = BDecls [ pbind (p "lst") (List (map (v . (\n -> "f" <> show n) . fst) lst)) Nothing ] + retstmt = v "return" + `App` List [ v "mkInstance" + `App` List [] + `App` (con "AppT" + `App` (v "con" `App` l (typeclassNameT t)) + `App` (con "ConT" `App` (v "n")) + ) + `App` (v "lst") + ] diff --git a/lib/FFICXX/Generate/Code/MethodDef.hs b/lib/FFICXX/Generate/Code/MethodDef.hs --- a/lib/FFICXX/Generate/Code/MethodDef.hs +++ b/lib/FFICXX/Generate/Code/MethodDef.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.MethodDef --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -12,24 +15,56 @@ module FFICXX.Generate.Code.MethodDef where -import FFICXX.Generate.Type.Class -import FFICXX.Generate.Util +import Data.Monoid ( (<>) ) +-- +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Util +returnCpp :: Bool -- ^ for simple type + -> Types + -> String -- ^ call string + -> String +returnCpp b ret callstr = + case ret of + Void -> callstr <> ";" + SelfType -> "return to_nonconst((Type *)" + <> callstr <> ") ;" + CT (CRef _) _ -> "return ((*)"<>callstr<>");" + CT _ _ -> "return "<>callstr<>";" + CPT (CPTClass c') _ -> "return to_nonconst<"<>str<>"_t,"<>str + <>">(("<>str<>"*)"<>callstr<>");" + where str = class_name c' + CPT (CPTClassRef _c') _ -> "return ((*)"<>callstr<>");" + CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str + <>">(new "<>str<>"("<>callstr<>"));" + where str = class_name c' + + TemplateApp _ _ _ -> "return (" <> callstr <> ");" + TemplateType _ -> error "returnCpp: TemplateType" + TemplateParam _ -> + if b then "return (" <> callstr <> ");" + else "return to_nonconst((Type *)&(" + <> callstr <> ")) ;" + + + -- Function Declaration and Definition funcToDecl :: Class -> Function -> String funcToDecl c func | isNewFunc func || isStaticFunc func = - let tmpl = "$returntype$ Type ## _$funcname$ ( $args$ )" - in render tmpl [ ("returntype", rettypeToString (genericFuncRet func)) - , ("funcname", aliasedFuncName c func) - , ("args", argsToStringNoSelf (genericFuncArgs func)) ] + let tmpl = "$returntype Type ## _$funcname ( $args )" + in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func)) + , ("funcname", aliasedFuncName c func) + , ("args", argsToStringNoSelf (genericFuncArgs func)) + ]) | otherwise = - let tmpl = "$returntype$ Type ## _$funcname$ ( $args$ )" - in render tmpl [ ("returntype", rettypeToString (genericFuncRet func)) - , ("funcname", aliasedFuncName c func) - , ("args", argsToString (genericFuncArgs func)) ] + let tmpl = "$returntype Type ## _$funcname ( $args )" + in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func)) + , ("funcname", aliasedFuncName c func) + , ("args", argsToString (genericFuncArgs func)) + ]) @@ -41,8 +76,8 @@ funcToDef c func | isNewFunc func = let declstr = funcToDecl c func - callstr = "(" ++ argsToCallString (genericFuncArgs func) ++ ")" - returnstr = "Type * newp = new Type " ++ callstr ++ "; \\\nreturn to_nonconst(newp);" + callstr = "(" <> argsToCallString (genericFuncArgs func) <> ")" + returnstr = "Type * newp = new Type " <> callstr <> "; \\\nreturn to_nonconst(newp);" in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | isDeleteFunc func = let declstr = funcToDecl c func @@ -50,33 +85,18 @@ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | isStaticFunc func = let declstr = funcToDecl c func - callstr = cppFuncName c func ++ "(" - ++ argsToCallString (genericFuncArgs func) - ++ ")" - returnstr = case (genericFuncRet func) of - Void -> callstr ++ ";" - SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" - (CT _ctyp _isconst) -> "return "++callstr++";" - (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str - ++">(("++str++"*)"++callstr++");" - where str = class_name c' - (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" - in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + callstr = cppFuncName c func <> "(" + <> argsToCallString (genericFuncArgs func) + <> ")" + returnstr = returnCpp False (genericFuncRet func) callstr + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] | otherwise = let declstr = funcToDecl c func - callstr = -- "to_nonconst(p)->" - "TYPECASTMETHOD(Type,"++ aliasedFuncName c func ++ "," ++ class_name c ++ ")(p)->" - ++ cppFuncName c func ++ "(" - ++ argsToCallString (genericFuncArgs func) - ++ ")" - returnstr = case (genericFuncRet func) of - Void -> callstr ++ ";" - SelfType -> "return to_nonconst((Type *)" ++ callstr ++ ") ;" - (CT _ctyp _isconst) -> "return "++callstr++";" - (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str - ++">(("++str++"*)"++callstr++");" - where str = class_name c' - (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" + callstr = "TYPECASTMETHOD(Type,"<> aliasedFuncName c func <> "," <> class_name c <> ")(p)->" + <> cppFuncName c func <> "(" + <> argsToCallString (genericFuncArgs func) + <> ")" + returnstr = returnCpp False (genericFuncRet func) callstr in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] @@ -85,6 +105,49 @@ funcsToDefs c = intercalateWith connBSlash (funcToDef c) +tmplFunToDecl :: Bool -> TemplateClass -> TemplateFunction -> String +tmplFunToDecl b t@TmplCls {..} TFun {..} = + subst "$ret ${tname}_${fname}_ ## Type ( $args )" + (context [ ("tname", tclass_name ) + , ("fname", tfun_name ) + , ("args" , tmplAllArgsToString Self t tfun_args ) + , ("ret" , tmplRetTypeToString b tfun_ret ) ]) +tmplFunToDecl b t@TmplCls {..} TFunNew {..} = + subst "$ret ${tname}_new_ ## Type ( $args )" + (context [ ("tname", tclass_name ) + , ("args" , tmplAllArgsToString NoSelf t tfun_new_args ) + , ("ret" , tmplRetTypeToString b (TemplateType t)) ]) +tmplFunToDecl _ t@TmplCls {..} TFunDelete = + subst "$ret ${tname}_delete_ ## Type ( $args )" + (context [ ("tname", tclass_name ) + , ("args" , tmplAllArgsToString Self t [] ) + , ("ret" , "void" ) ]) + + + +tmplFunToDef :: Bool -- ^ for simple type + -> TemplateClass + -> TemplateFunction + -> String +tmplFunToDef b t@TmplCls {..} f = intercalateWith connBSlash id [declstr, " {", " "<>returnstr, " }"] + where + declstr = tmplFunToDecl b t f + callstr = + case f of + TFun {..} -> "(reinterpret_cast<" <> tclass_oname <> "*>(p))->" + <> tfun_oname <> "(" + <> tmplAllArgsToCallString tfun_args + <> ")" + TFunNew {..} -> "new " <> tclass_oname <> "(" + <> tmplAllArgsToCallString tfun_new_args + <> ")" + TFunDelete -> "delete (reinterpret_cast<" <> tclass_oname <> "*>(p))" + + returnstr = + case f of + TFunNew {..} -> "return reinterpret_cast("<>callstr<>");" + TFunDelete -> callstr <> ";" + TFun {..} -> returnCpp b (tfun_ret) callstr diff --git a/lib/FFICXX/Generate/ContentMaker.hs b/lib/FFICXX/Generate/ContentMaker.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/ContentMaker.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.ContentMaker +-- Copyright : (c) 2011-2017 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + +module FFICXX.Generate.ContentMaker where + +import Control.Lens ( set,at ) +import Control.Monad.Trans.Reader +import Data.Function ( on ) +import qualified Data.Map as M +import Data.Monoid ( (<>) ) +import Data.List +import Data.List.Split ( splitOn ) +import Data.Maybe +import Data.Text ( Text ) +import Language.Haskell.Exts.Syntax ( Module(..), Decl(..) ) +import Language.Haskell.Exts.Pretty ( prettyPrint ) +import System.FilePath +-- +import FFICXX.Generate.Code.Cpp +import FFICXX.Generate.Code.HsFFI +import FFICXX.Generate.Code.HsFrontEnd +import FFICXX.Generate.Type.Annotate +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.Module +import FFICXX.Generate.Type.PackageInterface ( TypeMacro(..), HeaderName(..) + , PackageInterface, PackageName(..) + , ClassName(..) + ) +import FFICXX.Generate.Util +import FFICXX.Generate.Util.HaskellSrcExts +-- + +srcDir :: FilePath -> FilePath +srcDir installbasedir = installbasedir "src" + +csrcDir :: FilePath -> FilePath +csrcDir installbasedir = installbasedir "csrc" + +---- common function for daughter + +-- | +mkGlobal :: [Class] -> ClassGlobal +mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap + + +-- | +buildDaughterDef :: ((String,[Class]) -> String) + -> DaughterMap + -> String +buildDaughterDef f m = + let lst = M.toList m + f' (x,xs) = f (x,filter (not.isAbstractClass) xs) + in (concatMap f' lst) + +-- | +buildParentDef :: ((Class,Class)->String) -> Class -> String +buildParentDef f cls = g (class_allparents cls,cls) + where g (ps,c) = concatMap (\p -> f (p,c)) ps + +-- | +mkProtectedFunctionList :: Class -> String +mkProtectedFunctionList c = + (unlines + . map (\x->"#define IS_" <> class_name c <> "_" <> x <> "_PROTECTED ()") + . unProtected . class_protected) c + +-- | +buildTypeDeclHeader :: TypeMacro -- ^ typemacro + -> [Class] + -> String +buildTypeDeclHeader (TypMcro typemacro) classes = + let typeDeclBodyStr = genAllCppHeaderTmplType classes + in subst + "#ifdef __cplusplus\n\ + \extern \"C\" { \n\ + \#endif\n\ + \\n\ + \#ifndef $typemacro\n\ + \#define $typemacro\n\ + \\n\ + \$typeDeclBody\n\ + \\n\ + \#endif // $typemacro\n\ + \\n\ + \#ifdef __cplusplus\n\ + \}\n\ + \#endif\n" + (context [ ("typeDeclBody", typeDeclBodyStr ) + , ("typemacro" , typemacro ) ]) + + + +declarationTemplate :: Text +declarationTemplate = + "#ifdef __cplusplus\n\ + \extern \"C\" { \n\ + \#endif\n\ + \\n\ + \#ifndef $typemacro\n\ + \#define $typemacro\n\ + \\n\ + \#include \"${cprefix}Type.h\"\ + \\n\ + \$declarationheader\n\ + \\n\ + \$declarationbody\n\ + \\n\ + \#endif // $typemacro\n\ + \\n\ + \#ifdef __cplusplus\n\ + \}\n\ + \#endif\n" + +-- | +buildDeclHeader :: TypeMacro -- ^ typemacro prefix + -> String -- ^ C prefix + -> ClassImportHeader + -> String +buildDeclHeader (TypMcro typemacroprefix) cprefix header = + let classes = [cihClass header] + aclass = cihClass header + typemacrostr = typemacroprefix <> class_name aclass <> "__" + declHeaderStr = intercalateWith connRet (\x->"#include \""<>x<>"\"") $ + map unHdrName (cihIncludedHPkgHeadersInH header) + declDefStr = genAllCppHeaderTmplVirtual classes + `connRet2` + genAllCppHeaderTmplNonVirtual classes + `connRet2` + genAllCppDefTmplVirtual classes + `connRet2` + genAllCppDefTmplNonVirtual classes + classDeclsStr = if (fst.hsClassName) aclass /= "Deletable" + then buildParentDef genCppHeaderInstVirtual aclass + `connRet2` + genCppHeaderInstVirtual (aclass, aclass) + `connRet2` + genAllCppHeaderInstNonVirtual classes + else "" + declBodyStr = declDefStr + `connRet2` + classDeclsStr + in subst declarationTemplate + (context [ ("typemacro" , typemacrostr ) + , ("cprefix" , cprefix ) + , ("declarationheader", declHeaderStr ) + , ("declarationbody" , declBodyStr ) ]) + + +definitionTemplate :: Text +definitionTemplate = + "#include \n\ + \$header\n\ + \\n\ + \$namespace\n\ + \\n\ + \#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n\ + \\n\ + \#define TYPECASTMETHOD(cname,mname,oname) \\\n\ + \ IIF( CHECKPROTECT(cname,mname) ) ( \\\n\ + \ (to_nonconst), \\\n\ + \ (to_nonconst) )\n\ + \\n\ + \$cppbody\n" + + +-- | +buildDefMain :: ClassImportHeader + -> String +buildDefMain header = + let classes = [cihClass header] + headerStr = genAllCppHeaderInclude header <> "\n#include \"" <> (unHdrName (cihSelfHeader header)) <> "\"" + namespaceStr = (concatMap (\x->"using namespace " <> unNamespace x <> ";\n") . cihNamespace) header + aclass = cihClass header + cppBody = mkProtectedFunctionList (cihClass header) + `connRet` + buildParentDef genCppDefInstVirtual (cihClass header) + `connRet` + if isAbstractClass aclass + then "" + else genCppDefInstVirtual (aclass, aclass) + `connRet` + genAllCppDefInstNonVirtual classes + in subst definitionTemplate (context ([ ("header" , headerStr ) + , ("namespace", namespaceStr ) + , ("cppbody" , cppBody ) ])) + +-- | +buildTopLevelFunctionHeader :: TypeMacro -- ^ typemacro prefix + -> String -- ^ C prefix + -> TopLevelImportHeader + -> String +buildTopLevelFunctionHeader (TypMcro typemacroprefix) cprefix tih = + let typemacrostr = typemacroprefix <> "TOPLEVEL" <> "__" + declHeaderStr = intercalateWith connRet (\x->"#include \""<>x<>"\"") + . map (unHdrName . cihSelfHeader) . tihClassDep $ tih + declBodyStr = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih) + in subst declarationTemplate (context [ ("typemacro" , typemacrostr ) + , ("cprefix" , cprefix ) + , ("declarationheader", declHeaderStr ) + , ("declarationbody" , declBodyStr ) ]) + +-- | +buildTopLevelFunctionCppDef :: TopLevelImportHeader -> String +buildTopLevelFunctionCppDef tih = + let cihs = tihClassDep tih + declHeaderStr = "#include \"" <> tihHeaderFileName tih <.> "h" <> "\"" + `connRet2` + (intercalate "\n" (nub (map genAllCppHeaderInclude cihs))) + `connRet2` + ((intercalateWith connRet (\x->"#include \""<>x<>"\"") . map (unHdrName . cihSelfHeader)) cihs) + allns = nubBy ((==) `on` unNamespace) (tihClassDep tih >>= cihNamespace) + namespaceStr = do ns <- allns + ("using namespace " <> unNamespace ns <> ";\n") + declBodyStr = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih) + + in subst definitionTemplate (context [ ("header" , declHeaderStr) + , ("namespace", namespaceStr ) + , ("cppbody" , declBodyStr ) ]) + +-- | +buildTemplateHeader :: TypeMacro -- ^ typemacro prefix + -- -> String -- ^ C prefix + -> TemplateClass + -> String +buildTemplateHeader (TypMcro typemacroprefix) t = + let typemacrostr = typemacroprefix <> "TEMPLATE" <> "__" + fs = tclass_funcs t + deffunc = intercalateWith connRet (genTmplFunCpp False t) fs + ++ "\n\n" + ++ intercalateWith connRet (genTmplFunCpp True t) fs + classlevel = genTmplClassCpp False t fs ++ "\n\n" ++ genTmplClassCpp True t fs + in subst + "#ifndef $typemacro\n\ + \#define $typemacro\n\ + \\n\ + \$deffunc\n\ + \$classlevel\n\ + \#endif\n" + (context [ ("typemacro", typemacrostr ) + , ("deffunc" , deffunc ) + , ("classlevel" , classlevel ) + ]) + + +-- | +buildFFIHsc :: ClassModule -> Module +buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody + where mname = cmModule m + headers = cmCIH m + ffiImports = [ mkImport "Foreign.C", mkImport "Foreign.Ptr", mkImport (mname <.> "RawType") ] + <> genImportInFFI m + <> genExtraImport m + hscBody = concatMap genHsFFI headers + + +-- | +buildRawTypeHs :: ClassModule -> Module +buildRawTypeHs m = mkModule (cmModule m <.> "RawType") + [lang [ "ForeignFunctionInterface", "TypeFamilies", "MultiParamTypeClasses" + , "FlexibleInstances", "TypeSynonymInstances" + , "EmptyDataDecls", "ExistentialQuantification", "ScopedTypeVariables" ]] + rawtypeImports rawtypeBody + where rawtypeImports = [ {- mkImport "Foreign.ForeignPtr", -} + mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + ] + rawtypeBody = concatMap hsClassRawType . filter (not.isAbstractClass) . cmClass $ m + +-- | +buildInterfaceHs :: AnnotateMap -> ClassModule -> Module +buildInterfaceHs amap m = mkModule (cmModule m <.> "Interface") + [lang [ "EmptyDataDecls", "ExistentialQuantification" + , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface" + , "MultiParamTypeClasses" + , "ScopedTypeVariables" + , "TypeFamilies", "TypeSynonymInstances" + ]] + ifaceImports ifaceBody + where classes = cmClass m + ifaceImports = [ mkImport "Data.Word" + , mkImport "Foreign.C" + , mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" ] + <> genImportInInterface m + <> genExtraImport m + ifaceBody = + runReader (mapM genHsFrontDecl classes) amap + <> (concatMap genHsFrontUpcastClass . filter (not.isAbstractClass)) classes + <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes + +-- | +buildCastHs :: ClassModule -> Module +buildCastHs m = mkModule (cmModule m <.> "Cast") + [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies" + , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ] + castImports body + where classes = cmClass m + castImports = [ mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + , mkImport "System.IO.Unsafe" ] + <> genImportInCast m + body = mapMaybe genHsFrontInstCastable classes + <> mapMaybe genHsFrontInstCastableSelf classes + +-- | +buildImplementationHs :: AnnotateMap -> ClassModule -> Module +buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation") + [ lang [ "EmptyDataDecls" + , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface" + , "IncoherentInstances" + , "MultiParamTypeClasses" + , "OverlappingInstances" + , "TypeFamilies", "TypeSynonymInstances" + ] ] + implImports implBody + where classes = cmClass m + implImports = [ mkImport "FFICXX.Runtime.Cast" + , mkImport "Data.Word" + , mkImport "Foreign.C" + , mkImport "Foreign.Ptr" + , mkImport "System.IO.Unsafe" ] + <> genImportInImplementation m + <> genExtraImport m + f :: Class -> [Decl] + f y = concatMap (flip genHsFrontInst y) (y:class_allparents y) + + implBody = concatMap f classes + <> runReader (concat <$> mapM genHsFrontInstNew classes) amap + <> concatMap genHsFrontInstNonVirtual classes + <> concatMap genHsFrontInstStatic classes + +buildTemplateHs :: TemplateClassModule -> Module +buildTemplateHs m = mkModule (tcmModule m <.> "Template") + [lang [ "EmptyDataDecls", "FlexibleInstances", "MultiParamTypeClasses" + , "TypeFamilies"] ] + [ mkImport "Foreign.C.Types" + , mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + ] + body + where ts = tcmTemplateClasses m + body = concatMap genTmplInterface ts + +buildTHHs :: TemplateClassModule -> Module +buildTHHs m = mkModule (tcmModule m <.> "TH") + [lang ["TemplateHaskell"] ] + ([ mkImport "Data.Char" + , mkImport "Data.Monoid" + , mkImport "Foreign.C.Types" + , mkImport "Foreign.Ptr" + , mkImport "Language.Haskell.TH" + , mkImport "Language.Haskell.TH.Syntax" + , mkImport "FFICXX.Runtime.TH" + ] <> imports) + body + where ts = tcmTemplateClasses m + imports = [ mkImport (tcmModule m <.> "Template") ] + body = concatMap genTmplImplementation ts + <> concatMap (\t -> genTmplInstance t (tclass_funcs t)) ts + +-- | +buildInterfaceHSBOOT :: String -> Module +buildInterfaceHSBOOT mname = mkModule (mname <.> "Interface") [] [] hsbootBody + where cname = last (splitOn "." mname) + hsbootBody = [ mkClass [] ('I':cname) [mkTBind "a"] [] ] + +-- | +buildModuleHs :: ClassModule -> Module +buildModuleHs m = mkModuleE (cmModule m) [] (concatMap genExport (cmClass m)) (genImportInModule (cmClass m)) [] + +-- | +buildPkgHs :: String -> [ClassModule] -> TopLevelImportHeader -> String +buildPkgHs modname mods tih = + let tfns = tihFuncs tih + exportListStr = intercalateWith (conn "\n, ") ((\x->"module " <> x).cmModule) mods + <> if null tfns + then "" + else "\n, " <> intercalateWith (conn "\n, ") hsFrontNameForTopLevelFunction tfns + importListStr = intercalateWith connRet ((\x->"import " <> x).cmModule) mods + <> if null tfns + then "" + else "" `connRet2` "import Foreign.C" `connRet` "import Foreign.Ptr" + `connRet` "import FFICXX.Runtime.Cast" + `connRet` + intercalateWith connRet + ((\x->"import " <> modname <> "." <> x <> ".RawType") + .fst.hsClassName.cihClass) (tihClassDep tih) + topLevelDefStr = intercalate "\n" (map (prettyPrint . genTopLevelFuncFFI tih) tfns) + `connRet2` + intercalate "\n\n" (map (intercalateWith connRet prettyPrint) (map genTopLevelFuncDef tfns)) + in subst + "module $summarymod (\n\ + \ $exportList\n\ + \) where\n\ + \\n\ + \$importList\n\ + \$topLevelDef\n" + (context [ ("summarymod" , modname ) + , ("exportList" , exportListStr ) + , ("importList" , importListStr ) + , ("topLevelDef", topLevelDefStr) ]) + + + +-- | +buildPackageInterface :: PackageInterface + -> PackageName + -> [ClassImportHeader] + -> PackageInterface +buildPackageInterface pinfc pkgname = foldr f pinfc + where f cih repo = + let name = (class_name . cihClass) cih + header = cihSelfHeader cih + in set (at (pkgname,ClsName name)) (Just header) repo + diff --git a/lib/FFICXX/Generate/Generator/ContentMaker.hs b/lib/FFICXX/Generate/Generator/ContentMaker.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Generator/ContentMaker.hs +++ /dev/null @@ -1,493 +0,0 @@ -{-# LANGUAGE GADTs #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Generator.ContentMaker --- Copyright : (c) 2011-2013,2015 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Generator.ContentMaker where - -import Control.Applicative -import Control.Lens (set,at) -import Control.Monad.Trans.Reader -import Data.Function (on) -import qualified Data.Map as M -import Data.List -import Data.List.Split (splitOn) -import Data.Maybe -import System.FilePath -import Text.StringTemplate hiding (render) --- -import FFICXX.Generate.Code.Cpp -import FFICXX.Generate.Code.HsFFI -import FFICXX.Generate.Code.HsFrontEnd -import FFICXX.Generate.Type.Annotate -import FFICXX.Generate.Type.Class -import qualified FFICXX.Generate.Type.PackageInterface as T -import FFICXX.Generate.Util --- - -srcDir :: FilePath -> FilePath -srcDir installbasedir = installbasedir "src" - -csrcDir :: FilePath -> FilePath -csrcDir installbasedir = installbasedir "csrc" - -pkgModuleTemplate :: String -pkgModuleTemplate = "Pkg.hs" - -moduleTemplate :: String -moduleTemplate = "module.hs" - -hsbootTemplate :: String -hsbootTemplate = "Class.hs-boot" - --- cabalTemplate :: String --- cabalTemplate = "Pkg.cabal" - -declarationTemplate :: String -declarationTemplate = "Module.h" - -typeDeclHeaderFileName :: String -typeDeclHeaderFileName = "PkgType.h" - -declbodyTemplate :: String -declbodyTemplate = "declbody.h" - -funcdeclTemplate :: String -funcdeclTemplate = "funcdecl.h" - -definitionTemplate :: String -definitionTemplate = "Pkg.cpp" - -classDefTemplate :: String -classDefTemplate = "classdef.cpp" - -functionTemplate :: String -functionTemplate = "function.cpp" - -funcbodyTemplate :: String -funcbodyTemplate = "functionbody.cpp" - -headerFileName :: String -headerFileName = "Module.h" - -cppFileName :: String -cppFileName = "Pkg.cpp" - -hscFileName :: String -hscFileName = "FFI.hsc" - -hsFileName :: String -hsFileName = "Implementation.hs" - -typeHsFileName :: String -typeHsFileName = "Interface.hs" - -existHsFileName :: String -existHsFileName = "Existential.hs" - -rawtypeHsFileName :: String -rawtypeHsFileName = "RawType.hs" - -ffiHscFileName :: String -ffiHscFileName = "FFI.hsc" - -interfaceHsFileName :: String -interfaceHsFileName = "Interface.hs" - -castHsFileName :: String -castHsFileName = "Cast.hs" - -implementationHsFileName :: String -implementationHsFileName = "Implementation.hs" - -existentialHsFileName :: String -existentialHsFileName = "Existential.hs" - - ----- common function for daughter - - --- | -mkGlobal :: [Class] -> ClassGlobal -mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap - - --- | -mkDaughterDef :: ((String,[Class]) -> String) - -> DaughterMap - -> String -mkDaughterDef f m = - let lst = M.toList m - f' (x,xs) = f (x,filter (not.isAbstractClass) xs) - in (concatMap f' lst) - --- | -mkParentDef :: ((Class,Class)->String) -> Class -> String -mkParentDef f cls = g (class_allparents cls,cls) - where g (ps,c) = concatMap (\p -> f (p,c)) ps - - --- | -mkProtectedFunctionList :: Class -> String -mkProtectedFunctionList c = - (unlines - . map (\x->"#define IS_" ++ class_name c ++ "_" ++ x ++ "_PROTECTED ()") - . unProtected . class_protected) c - - - - --- | -mkTypeDeclHeader :: STGroup String -- -> ClassGlobal - -> T.TypeMacro -- ^ typemacro - -> [Class] - -> String -mkTypeDeclHeader templates (T.TypMcro typemacro) classes = - let typeDeclBodyStr = genAllCppHeaderTmplType classes - in renderTemplateGroup - templates - [ ("typeDeclBody", typeDeclBodyStr ) - , ("typemacro", typemacro ) - - ] - typeDeclHeaderFileName - --- | -mkDeclHeader :: STGroup String - -- -> ClassGlobal - -> T.TypeMacro -- ^ typemacro prefix - -> String -- ^ C prefix - -> ClassImportHeader - -> String -mkDeclHeader templates (T.TypMcro typemacroprefix) cprefix header = - let classes = [cihClass header] - aclass = cihClass header - typemacrostr = typemacroprefix ++ class_name aclass ++ "__" - declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") $ - map T.unHdrName (cihIncludedHPkgHeadersInH header) - declDefStr = genAllCppHeaderTmplVirtual classes - `connRet2` - genAllCppHeaderTmplNonVirtual classes - `connRet2` - genAllCppDefTmplVirtual classes - `connRet2` - genAllCppDefTmplNonVirtual classes - -- dsmap = cgDaughterSelfMap cglobal - classDeclsStr = if (fst.hsClassName) aclass /= "Deletable" - then mkParentDef genCppHeaderInstVirtual aclass - `connRet2` - genCppHeaderInstVirtual (aclass, aclass) - `connRet2` - genAllCppHeaderInstNonVirtual classes - else "" - declBodyStr = declDefStr - `connRet2` - classDeclsStr - in renderTemplateGroup - templates - [ ("typemacro", typemacrostr) - , ("cprefix", cprefix) - , ("declarationheader", declHeaderStr ) - , ("declarationbody", declBodyStr ) ] - declarationTemplate - --- | -mkDefMain :: STGroup String - -> ClassImportHeader - -> String -mkDefMain templates header = - let classes = [cihClass header] - headerStr = genAllCppHeaderInclude header ++ "\n#include \"" ++ (T.unHdrName (cihSelfHeader header)) ++ "\"" - namespaceStr = (concatMap (\x->"using namespace " ++ unNamespace x ++ ";\n") . cihNamespace) header - aclass = cihClass header - cppBody = mkProtectedFunctionList (cihClass header) - `connRet` - mkParentDef genCppDefInstVirtual (cihClass header) - `connRet` - if isAbstractClass aclass - then "" - else genCppDefInstVirtual (aclass, aclass) - `connRet` - genAllCppDefInstNonVirtual classes - in renderTemplateGroup - templates - [ ("header" , headerStr ) - , ("namespace", namespaceStr ) - , ("cppbody", cppBody ) - ] - definitionTemplate - - --- | -mkTopLevelFunctionHeader :: STGroup String - -> T.TypeMacro -- ^ typemacro prefix - -> String -- ^ C prefix - -> TopLevelImportHeader - -> String -mkTopLevelFunctionHeader templates (T.TypMcro typemacroprefix) cprefix tih = - let typemacrostr = typemacroprefix ++ "TOPLEVEL" ++ "__" - declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") - . map (T.unHdrName . cihSelfHeader) . tihClassDep $ tih - declBodyStr = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih) - in renderTemplateGroup - templates - [ ("typemacro", typemacrostr) - , ("cprefix", cprefix) - , ("declarationheader", declHeaderStr ) - , ("declarationbody", declBodyStr ) ] - declarationTemplate - - --- | -mkTopLevelFunctionCppDef :: STGroup String - -> String -- ^ C prefix - -> TopLevelImportHeader - -> String -mkTopLevelFunctionCppDef templates cprefix tih = - let cihs = tihClassDep tih - declHeaderStr = "#include \"" ++ tihHeaderFileName tih <.> "h" ++ "\"" - `connRet2` - (intercalate "\n" (nub (map genAllCppHeaderInclude cihs))) - `connRet2` - ((intercalateWith connRet (\x->"#include \""++x++"\"") . map (T.unHdrName . cihSelfHeader)) cihs) - allns = nubBy ((==) `on` unNamespace) (tihClassDep tih >>= cihNamespace) - namespaceStr = do ns <- allns - ("using namespace " ++ unNamespace ns ++ ";\n") - declBodyStr = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih) - - in renderTemplateGroup - templates - [ ("header", declHeaderStr) - , ("namespace", namespaceStr) - , ("cppbody", declBodyStr ) ] - definitionTemplate - --- | -mkFFIHsc :: STGroup String - -> ClassModule - -> String -mkFFIHsc templates m = - renderTemplateGroup templates - [ ("ffiHeader", ffiHeaderStr) - , ("ffiImport", ffiImportStr) - , ("cppInclude", cppIncludeStr) - , ("hsFunctionBody", genAllHsFFI headers) ] - ffiHscFileName - where mname = cmModule m - -- classes = cmClass m - headers = cmCIH m - ffiHeaderStr = "module " ++ mname <.> "FFI where\n" - ffiImportStr = "import " ++ mname <.> "RawType\n" - ++ genImportInFFI m - cppIncludeStr = genModuleIncludeHeader headers - --- | -mkRawTypeHs :: STGroup String - -> ClassModule - -> String -mkRawTypeHs templates m = - renderTemplateGroup templates [ ("rawtypeHeader", rawtypeHeaderStr) - , ("rawtypeBody", rawtypeBodyStr)] rawtypeHsFileName - where rawtypeHeaderStr = "module " ++ cmModule m <.> "RawType where\n" - classes = cmClass m - rawtypeBodyStr = - intercalateWith connRet2 hsClassRawType (filter (not.isAbstractClass) classes) - --- | -mkInterfaceHs :: AnnotateMap - -> STGroup String - -> ClassModule - -> String -mkInterfaceHs amap templates m = - renderTemplateGroup templates [ ("ifaceHeader", ifaceHeaderStr) - , ("ifaceImport", ifaceImportStr) - , ("ifaceBody", ifaceBodyStr)] "Interface.hs" - where ifaceHeaderStr = "module " ++ cmModule m <.> "Interface where\n" - classes = cmClass m - ifaceImportStr = genImportInInterface m - ifaceBodyStr = - runReader (genAllHsFrontDecl classes) amap - `connRet2` - intercalateWith connRet hsClassExistType (filter (not.isAbstractClass) classes) - `connRet2` - runReader (genAllHsFrontUpcastClass (filter (not.isAbstractClass) classes)) amap - `connRet2` - runReader (genAllHsFrontDowncastClass (filter (not.isAbstractClass) classes)) amap - --- | -mkCastHs :: STGroup String -> ClassModule -> String -mkCastHs templates m = - renderTemplateGroup templates [ ("castHeader", castHeaderStr) - , ("castImport", castImportStr) - , ("castBody", castBodyStr) ] - castHsFileName - where castHeaderStr = "module " ++ cmModule m <.> "Cast where\n" - classes = cmClass m - castImportStr = genImportInCast m - castBodyStr = - genAllHsFrontInstCastable classes - `connRet2` - intercalateWith connRet2 genHsFrontInstCastableSelf classes - --- | -mkImplementationHs :: AnnotateMap - -> STGroup String -- ^ template - -> ClassModule - -> String -mkImplementationHs amap templates m = - renderTemplateGroup templates - [ ("implHeader", implHeaderStr) - , ("implImport", implImportStr) - , ("implBody", implBodyStr ) ] - "Implementation.hs" - where classes = cmClass m - implHeaderStr = "module " ++ cmModule m <.> "Implementation where\n" - implImportStr = genImportInImplementation m - f y = intercalateWith connRet (flip genHsFrontInst y) (y:class_allparents y ) - g y = intercalateWith connRet (flip genHsFrontInstExistVirtual y) (y:class_allparents y ) - - implBodyStr = - intercalateWith connRet2 f classes - `connRet2` - intercalateWith connRet2 g (filter (not.isAbstractClass) classes) - `connRet2` - runReader (genAllHsFrontInstNew classes) amap - `connRet2` - genAllHsFrontInstNonVirtual classes - `connRet2` - intercalateWith connRet id (mapMaybe genHsFrontInstStatic classes) - `connRet2` - genAllHsFrontInstExistCommon (filter (not.isAbstractClass) classes) - --- | -mkExistentialEach :: STGroup String - -> Class - -> [Class] - -> String -mkExistentialEach templates mother daughters = - let makeOneDaughterGADTBody daughter = render hsExistentialGADTBodyTmpl - [ ( "mother", (fst.hsClassName) mother ) - , ( "daughter",(fst.hsClassName) daughter ) ] - makeOneDaughterCastBody daughter = render hsExistentialCastBodyTmpl - [ ( "mother", (fst.hsClassName) mother ) - , ( "daughter", (fst.hsClassName) daughter) ] - gadtBody = intercalate "\n" (map makeOneDaughterGADTBody daughters) - castBody = intercalate "\n" (map makeOneDaughterCastBody daughters) - str = renderTemplateGroup - templates - [ ( "mother" , (fst.hsClassName) mother ) - , ( "GADTbody" , gadtBody ) - , ( "castbody" , castBody ) ] - "ExistentialEach.hs" - in str - --- | -mkExistentialHs :: STGroup String - -> ClassGlobal - -> ClassModule - -> String -mkExistentialHs templates cglobal m = - let classes = filter (not.isAbstractClass) (cmClass m) - dsmap = cgDaughterSelfMap cglobal - makeOneMother :: Class -> String - makeOneMother mother = - let daughters = case M.lookup (getClassModuleBase mother) dsmap of - Nothing -> error "error in mkExistential" - Just lst -> filter (not.isAbstractClass) lst - str = mkExistentialEach templates mother daughters - in str - existEachBody = intercalateWith connRet makeOneMother classes - existHeaderStr = "module " ++ cmModule m <.> "Existential where" - existImportStr = genImportInExistential dsmap m - hsfilestr = renderTemplateGroup - templates - [ ("existHeader", existHeaderStr) - , ("existImport", existImportStr) - , ("modname", cmModule m) - , ( "existEachBody" , existEachBody) ] - "Existential.hs" - in hsfilestr - --- | -mkInterfaceHSBOOT :: STGroup String -> String -> String -mkInterfaceHSBOOT templates mname = - let cname = last (splitOn "." mname) - hsbootbodystr = "class " ++ 'I':cname ++ " a" - hsbootstr = renderTemplateGroup - templates - [ ("moduleName", mname <.> "Interface") - , ("hsBootBody", hsbootbodystr) - ] - hsbootTemplate - in hsbootstr - - - --- | -mkModuleHs :: STGroup String - -> ClassModule - -> String -mkModuleHs templates m = - let str = renderTemplateGroup - templates - [ ("moduleName", cmModule m) - , ("exportList", genExportList (cmClass m)) - , ("importList", genImportInModule (cmClass m)) - ] - moduleTemplate - in str - - --- | -mkPkgHs :: String -> STGroup String -> [ClassModule] -> TopLevelImportHeader -> String -mkPkgHs modname templates mods tih = - let tfns = tihFuncs tih - exportListStr = intercalateWith (conn "\n, ") ((\x->"module " ++ x).cmModule) mods - ++ if null tfns - then "" - else "\n, " ++ intercalateWith (conn "\n, ") hsFrontNameForTopLevelFunction tfns - importListStr = intercalateWith connRet ((\x->"import " ++ x).cmModule) mods - ++ if null tfns - then "" - else "" `connRet2` "import Foreign.C" `connRet` "import Foreign.Ptr" - `connRet` "import FFICXX.Runtime.Cast" - `connRet` - intercalateWith connRet - ((\x->"import " ++ modname ++ "." ++ x ++ ".RawType") - .fst.hsClassName.cihClass) (tihClassDep tih) - topLevelDefStr = intercalateWith connRet2 (genTopLevelFuncFFI tih) tfns - `connRet2` - intercalateWith connRet2 genTopLevelFuncDef tfns - str = renderTemplateGroup - templates - [ ("summarymod", modname) - , ("exportList", exportListStr) - , ("importList", importListStr) - , ("topLevelDef", topLevelDefStr) - ] - pkgModuleTemplate - in str - - - - --- | -mkPackageInterface :: T.PackageInterface - -> T.PackageName - -> [ClassImportHeader] - -> T.PackageInterface -mkPackageInterface pinfc pkgname = foldr f pinfc - where f cih repo = - let name = (class_name . cihClass) cih - header = cihSelfHeader cih - in set (at (pkgname,T.ClsName name)) (Just header) repo - diff --git a/lib/FFICXX/Generate/Generator/Driver.hs b/lib/FFICXX/Generate/Generator/Driver.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Generator/Driver.hs +++ /dev/null @@ -1,236 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Generator.Driver --- Copyright : (c) 2011-2015 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : ianwookim@gmail.com --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Generator.Driver where - -import Control.Applicative ((<$>)) -import Control.Monad (when, forM_) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Digest.Pure.MD5 -import System.Directory -import System.FilePath -import System.IO -import System.Process -import Text.StringTemplate --- -import FFICXX.Generate.Type.Class -import FFICXX.Generate.Type.Annotate -import FFICXX.Generate.Type.PackageInterface -import FFICXX.Generate.Generator.ContentMaker -import FFICXX.Generate.Util - ----- ----- Header and Cpp file ----- - --- | -writeTypeDeclHeaders :: STGroup String - -> FilePath - -> TypeMacro -- ^ type macro - -> String -- ^ cprefix - -> [ClassImportHeader] - -> IO () -writeTypeDeclHeaders templates wdir typemacro cprefix headers = do - let fn = wdir cprefix ++ "Type.h" - classes = map cihClass headers - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkTypeDeclHeader templates typemacro classes) - --- | -writeDeclHeaders :: STGroup String - -> FilePath - -> TypeMacro - -> String -- ^ c prefix - -> ClassImportHeader - -> IO () -writeDeclHeaders templates wdir typemacroprefix cprefix header = do - let fn = wdir (unHdrName (cihSelfHeader header)) - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkDeclHeader templates typemacroprefix cprefix header) - --- | -writeTopLevelFunctionHeaders :: STGroup String - -> FilePath - -> TypeMacro - -> String -- ^ c prefix - -> TopLevelImportHeader - -> IO () -writeTopLevelFunctionHeaders templates wdir typemacroprefix cprefix tih = do - let fn = wdir tihHeaderFileName tih <.> "h" - withFile fn WriteMode $ \h -> - hPutStrLn h (mkTopLevelFunctionHeader templates typemacroprefix cprefix tih) - - - - -writeCppDef :: STGroup String -> FilePath -> ClassImportHeader -> IO () -writeCppDef templates wdir header = do - let fn = wdir cihSelfCpp header - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkDefMain templates header) - - --- | -writeTopLevelFunctionCppDef :: STGroup String - -> FilePath - -> TypeMacro - -> String -- ^ c prefix - -> TopLevelImportHeader - -> IO () -writeTopLevelFunctionCppDef templates wdir typemacroprefix cprefix tih = do - let fn = wdir tihHeaderFileName tih <.> "cpp" - withFile fn WriteMode $ \h -> hPutStrLn h (mkTopLevelFunctionCppDef templates cprefix tih) - - --- | -writeRawTypeHs :: STGroup String -> FilePath -> ClassModule -> IO () -writeRawTypeHs templates wdir m = do - let fn = wdir cmModule m <.> rawtypeHsFileName - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkRawTypeHs templates m) - --- | -writeFFIHsc :: STGroup String -> FilePath -> ClassModule -> IO () -writeFFIHsc templates wdir m = do - let fn = wdir cmModule m <.> ffiHscFileName - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkFFIHsc templates m) - --- | -writeInterfaceHs :: AnnotateMap -> STGroup String -> FilePath - -> ClassModule - -> IO () -writeInterfaceHs amap templates wdir m = do - let fn = wdir cmModule m <.> interfaceHsFileName - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkInterfaceHs amap templates m) - --- | -writeCastHs :: STGroup String -> FilePath -> ClassModule -> IO () -writeCastHs templates wdir m = do - let fn = wdir cmModule m <.> castHsFileName - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkCastHs templates m) - --- | -writeImplementationHs :: AnnotateMap - -> STGroup String - -> FilePath - -> ClassModule - -> IO () -writeImplementationHs amap templates wdir m = do - let fn = wdir cmModule m <.> implementationHsFileName - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkImplementationHs amap templates m) - --- | -writeExistentialHs :: STGroup String - -> ClassGlobal - -> FilePath - -> ClassModule - -> IO () -writeExistentialHs templates cglobal wdir m = do - let fn = wdir cmModule m <.> existentialHsFileName - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkExistentialHs templates cglobal m) - --- | -writeInterfaceHSBOOT :: STGroup String -> FilePath -> String -> IO () -writeInterfaceHSBOOT templates wdir mname = do - let fn = wdir mname <.> "Interface" <.> "hs-boot" - withFile fn WriteMode $ \h -> hPutStrLn h (mkInterfaceHSBOOT templates mname) - --- | -writeModuleHs :: STGroup String -> FilePath -> ClassModule -> IO () -writeModuleHs templates wdir m = do - let fn = wdir cmModule m <.> "hs" - withFile fn WriteMode $ \h -> do - hPutStrLn h (mkModuleHs templates m) - --- | -writePkgHs :: String -- ^ summary module - -> STGroup String - -> FilePath - -> [ClassModule] - -> TopLevelImportHeader - -> IO () -writePkgHs modname templates wdir mods tih = do - let fn = wdir modname <.> "hs" - str = mkPkgHs modname templates mods tih - withFile fn WriteMode $ \h -> hPutStrLn h str - - -notExistThenCreate :: FilePath -> IO () -notExistThenCreate dir = do - b <- doesDirectoryExist dir - if b then return () else system ("mkdir -p " ++ dir) >> return () - - -{- --- | now only create directory -copyPredefined :: FilePath -> FilePath -> String -> IO () -copyPredefined _tdir _ddir _prefix = do - return () - -- notExistThenCreate (ddir prefix) - -- copyFile (tdir "TypeCast.hs" ) (ddir prefix "TypeCast.hs") --} - -copyFileWithMD5Check :: FilePath -> FilePath -> IO () -copyFileWithMD5Check src tgt = do - b <- doesFileExist tgt - if b - then do - srcmd5 <- md5 <$> L.readFile src - tgtmd5 <- md5 <$> L.readFile tgt - if srcmd5 == tgtmd5 then return () else copyFile src tgt - else copyFile src tgt - - -copyCppFiles :: FilePath -> FilePath -> String -> (TopLevelImportHeader,[ClassImportHeader]) -> IO () -copyCppFiles wdir ddir cprefix (tih,cihs) = do - let thfile = cprefix ++ "Type.h" - tlhfile = tihHeaderFileName tih <.> "h" - tlcppfile = tihHeaderFileName tih <.> "cpp" - copyFileWithMD5Check (wdir thfile) (ddir thfile) - doesFileExist (wdir tlhfile) - >>= flip when (copyFileWithMD5Check (wdir tlhfile) (ddir tlhfile)) - doesFileExist (wdir tlcppfile) - >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) - forM_ cihs $ \header-> do - let hfile = unHdrName (cihSelfHeader header) - cppfile = cihSelfCpp header - copyFileWithMD5Check (wdir hfile) (ddir hfile) - copyFileWithMD5Check (wdir cppfile) (ddir cppfile) - -copyModule :: FilePath -> FilePath -> String -> ClassModule -> IO () -copyModule wdir ddir summarymod m = do - let modbase = cmModule m - let onefilecopy fname = do - let (fnamebody,fnameext) = splitExtension fname - (mdir,mfile) = moduleDirFile fnamebody - origfpath = wdir fname - (mfile',_mext') = splitExtension mfile - newfpath = ddir mdir mfile' ++ fnameext - b <- doesFileExist origfpath - when b $ do - notExistThenCreate (ddir mdir) - copyFileWithMD5Check origfpath newfpath - - onefilecopy $ modbase ++ ".hs" - onefilecopy $ modbase ++ ".RawType.hs" - onefilecopy $ modbase ++ ".FFI.hsc" - onefilecopy $ modbase ++ ".Interface.hs" - onefilecopy $ modbase ++ ".Cast.hs" - onefilecopy $ modbase ++ ".Implementation.hs" - onefilecopy $ modbase ++ ".Interface.hs-boot" - onefilecopy $ summarymod <.> "hs" - return () diff --git a/lib/FFICXX/Generate/QQ/Verbatim.hs b/lib/FFICXX/Generate/QQ/Verbatim.hs --- a/lib/FFICXX/Generate/QQ/Verbatim.hs +++ b/lib/FFICXX/Generate/QQ/Verbatim.hs @@ -16,8 +16,10 @@ import Language.Haskell.TH.Lib verbatim :: QuasiQuoter -verbatim = QuasiQuoter { - quoteExp = litE . stringL --- , quotePat = litP . stringP - } +verbatim = QuasiQuoter{ quoteExp = litE . stringL + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + -- , quotePat = litP . stringP + } 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 @@ -1,10 +1,11 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Class --- Copyright : (c) 2011-2013,2015 Ian-Woo Kim +-- Copyright : (c) 2011-2017 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -15,25 +16,24 @@ module FFICXX.Generate.Type.Class where -import Control.Applicative ((<$>),(<*>)) -import Data.Char -import Data.Default (Default(def)) -import Data.List -import Data.Monoid -import qualified Data.Map as M -import System.FilePath +import Control.Applicative ( (<$>),(<*>) ) +import Control.Monad.State +import Data.Char +import Data.Default ( Default(def) ) +import Data.List +import qualified Data.Map as M +import Data.Monoid ( (<>) ) +import Language.Haskell.Exts.Syntax ( Asst(..), Context + , Splice(..), Type(..), unit_tycon + ) +import System.FilePath -- -import FFICXX.Generate.Util -import FFICXX.Generate.Type.PackageInterface +import FFICXX.Generate.Util +import FFICXX.Generate.Util.HaskellSrcExts -- some type aliases --- type HeaderFileName = String --- type ClassName = String - - - -- | C types data CTypes = CTString | CTChar @@ -54,6 +54,7 @@ -- | C++ types data CPPTypes = CPTClass Class | CPTClassRef Class + | CPTClassCopy Class deriving Show -- | const flag @@ -64,10 +65,15 @@ | SelfType | CT CTypes IsConst | CPT CPPTypes IsConst + | TemplateApp { tapp_hstemplate :: TemplateClass + , tapp_HaskellTypeForParam :: String + , tapp_CppTypeForParam :: String } + | TemplateType TemplateClass + | TemplateParam String deriving Show cvarToStr :: CTypes -> IsConst -> String -> String -cvarToStr ctyp isconst varname = (ctypToStr ctyp isconst) `connspace` varname +cvarToStr ctyp isconst varname = ctypToStr ctyp isconst <> " " <> varname ctypToStr :: CTypes -> IsConst -> String ctypToStr ctyp isconst = @@ -84,10 +90,10 @@ CTVoidStar -> "void*" CTIntStar -> "int*" CTCharStarStar -> "char**" - CPointer s -> ctypToStr s NoConst ++ "*" - CRef s -> ctypToStr s NoConst ++ "*" + CPointer s -> ctypToStr s NoConst <> "*" + CRef s -> ctypToStr s NoConst <> "*" in case isconst of - Const -> "const" `connspace` typword + Const -> "const" <> " " <> typword NoConst -> typword @@ -241,6 +247,8 @@ cppclass :: Class -> String -> (Types, String) cppclass c vname = ( cppclass_ c, vname) + + cppclassconst :: Class -> String -> (Types, String) cppclassconst c vname = ( CPT (CPTClass c) Const, vname) @@ -250,7 +258,13 @@ cppclassref :: Class -> String -> (Types, String) cppclassref c vname = (cppclassref_ c, vname) +cppclasscopy_ :: Class -> Types +cppclasscopy_ c = CPT (CPTClassCopy c) NoConst +cppclasscopy :: Class -> String -> (Types, String) +cppclasscopy c vname = (cppclasscopy_ c, vname) + + hsCTypeName :: CTypes -> String hsCTypeName CTString = "CString" hsCTypeName CTChar = "CChar" @@ -264,12 +278,8 @@ hsCTypeName CTVoidStar = "(Ptr ())" hsCTypeName CTIntStar = "(Ptr CInt)" hsCTypeName CTCharStarStar = "(Ptr (CString))" -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) -hsCppTypeName (CPTClassRef c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c) +hsCTypeName (CPointer t) = "(Ptr " <> hsCTypeName t <> ")" +hsCTypeName (CRef t) = "(Ptr " <> hsCTypeName t <> ")" ------------- @@ -315,13 +325,8 @@ in toLower x : xs -data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String - , tihClassDep :: [ClassImportHeader] - , tihFuncs :: [TopLevelFunction] - } - isNewFunc :: Function -> Bool isNewFunc (Constructor _ _) = True isNewFunc _ = False @@ -331,10 +336,16 @@ isDeleteFunc _ = False isVirtualFunc :: Function -> Bool -isVirtualFunc (Destructor _) = True -isVirtualFunc (Virtual _ _ _ _) = True -isVirtualFunc _ = False +isVirtualFunc (Destructor _) = True +isVirtualFunc (Virtual _ _ _ _) = True +isVirtualFunc _ = False +isNonVirtualFunc :: Function -> Bool +isNonVirtualFunc (NonVirtual _ _ _ _) = True +isNonVirtualFunc _ = False + + + isStaticFunc :: Function -> Bool isStaticFunc (Static _ _ _ _) = True isStaticFunc _ = False @@ -354,15 +365,16 @@ argToString :: (Types,String) -> String argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname -argToString (SelfType, varname) = "Type ## _p " ++ varname +argToString (SelfType, varname) = "Type ## _p " <> varname argToString (CPT (CPTClass c) isconst, varname) = case isconst of - Const -> "const_" ++ cname ++ "_p " ++ varname - NoConst -> cname ++ "_p " ++ varname + Const -> "const_" <> cname <> "_p " <> varname + NoConst -> cname <> "_p " <> varname where cname = class_name c argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of - Const -> "const_" ++ cname ++ "_p " ++ varname - NoConst -> cname ++ "_p " ++ varname + Const -> "const_" <> cname <> "_p " <> varname + NoConst -> cname <> "_p " <> varname where cname = class_name c +argToString (TemplateApp _ _ _,varname) = "void* " <> varname argToString _ = error "undefined argToString" argsToString :: Args -> String @@ -375,11 +387,13 @@ argToCallString :: (Types,String) -> String +argToCallString (CT (CRef _) _,varname) = "(*"<> varname<> ")" argToCallString (CPT (CPTClass c) _,varname) = - "to_nonconst<"++str++","++str++"_t>("++varname++")" where str = class_name c + "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = class_name c argToCallString (CPT (CPTClassRef c) _,varname) = - "to_nonconstref<"++str++","++str++"_t>(*"++varname++")" where str = class_name c -argToCallString (CT (CRef _) _,varname) = "(*"++ varname++ ")" + "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c +argToCallString (TemplateApp _ _ cp,varname) = + "to_nonconst<"<>str<>",void>("<>varname<>")" where str = cp argToCallString (_,varname) = varname argsToCallString :: Args -> String @@ -390,11 +404,71 @@ 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 +rettypeToString (CPT (CPTClass c) _) = class_name c <> "_p" +rettypeToString (CPT (CPTClassRef c) _) = class_name c <> "_p" +rettypeToString (CPT (CPTClassCopy c) _) = class_name c <> "_p" +rettypeToString (TemplateApp _ _ _) = "void*" +rettypeToString (TemplateType _) = "void*" +rettypeToString (TemplateParam _) = "Type ## _p" +tmplArgToString :: TemplateClass -> (Types,String) -> String +tmplArgToString _ (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname +tmplArgToString t (SelfType, varname) = tclass_oname t <> "* " <> varname +tmplArgToString _ (CPT (CPTClass c) isconst, varname) = + case isconst of + Const -> "const_" <> class_name c <> "_p " <> varname + NoConst -> class_name c <> "_p " <> varname +tmplArgToString _ (CPT (CPTClassRef c) isconst, varname) = + case isconst of + Const -> "const_" <> class_name c <> "_p " <> varname + NoConst -> class_name c <> "_p " <> varname +tmplArgToString _ (TemplateApp _ _ _,_v) = error "tmpArgToString: TemplateApp" +tmplArgToString _ (TemplateType _,v) = "void* " <> v +tmplArgToString _ (TemplateParam _,v) = "Type " <> v +tmplArgToString _ _ = error "tmplArgToString: undefined" + +tmplAllArgsToString :: Selfness + -> TemplateClass + -> Args + -> String +tmplAllArgsToString s t args = + let args' = case s of + Self -> (TemplateType t, "p") : args + NoSelf -> args + in intercalateWith conncomma (tmplArgToString t) args' + + + +tmplArgToCallString :: (Types,String) -> String +tmplArgToCallString (CPT (CPTClass c) _,varname) = + "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = class_name c +tmplArgToCallString (CPT (CPTClassRef c) _,varname) = + "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c +tmplArgToCallString (CT (CRef _) _,varname) = "(*"<> varname<> ")" +tmplArgToCallString (_,varname) = varname + +tmplAllArgsToCallString :: Args -> String +tmplAllArgsToCallString = intercalateWith conncomma tmplArgToCallString + + + +tmplRetTypeToString :: Bool -- ^ is Simple type? + -> Types + -> String +tmplRetTypeToString _ (CT ctyp isconst) = ctypToStr ctyp isconst +tmplRetTypeToString _ Void = "void" +tmplRetTypeToString _ SelfType = "void*" +tmplRetTypeToString _ (CPT (CPTClass c) _) = class_name c <> "_p" +tmplRetTypeToString _ (CPT (CPTClassRef c) _) = class_name c <> "_p" +tmplRetTypeToString _ (CPT (CPTClassCopy c) _) = class_name c <> "_p" +tmplRetTypeToString _ (TemplateApp _ _ _) = "void*" +tmplRetTypeToString _ (TemplateType _) = "void*" +tmplRetTypeToString b (TemplateParam _) = if b + then "Type" + else "Type ## _p" + + + -------- newtype ProtectedMethod = Protected { unProtected :: [String] } @@ -433,34 +507,35 @@ , class_funcs :: [Function] } +data TemplateFunction = TFun { tfun_ret :: Types + , tfun_name :: String + , tfun_oname :: String + , tfun_args :: Args + , tfun_alias :: Maybe String } + | TFunNew { tfun_new_args :: Args } + | TFunDelete -newtype Namespace = NS { unNamespace :: String } deriving (Show) +data TemplateClass = TmplCls { tclass_cabal :: Cabal + , tclass_name :: String + , tclass_oname :: String + , tclass_param :: String + , tclass_funcs :: [TemplateFunction] + } -data ClassImportHeader = ClassImportHeader - { cihClass :: Class - , cihSelfHeader :: HeaderName - , cihNamespace :: [Namespace] - , cihSelfCpp :: String - , cihIncludedHPkgHeadersInH :: [HeaderName] -- [String] - , cihIncludedHPkgHeadersInCPP :: [HeaderName] -- [String] - , cihIncludedCPkgHeaders :: [HeaderName] - } deriving (Show) +instance Show TemplateClass where + show x = show (tclass_name x <> " " <> tclass_param x) -data ClassModule = ClassModule - { cmModule :: String - , cmClass :: [Class] - , cmCIH :: [ClassImportHeader] - , cmImportedModulesHighNonSource :: [String] - , cmImportedModulesRaw :: [String] - , cmImportedModulesHighSource :: [String] - , cmImportedModulesForFFI :: [String] - } deriving (Show) + data ClassGlobal = ClassGlobal { cgDaughterSelfMap :: DaughterMap , cgDaughterMap :: DaughterMap } +data Selfness = Self | NoSelf + + + -- | Check abstract class isAbstractClass :: Class -> Bool @@ -482,14 +557,17 @@ class_allparents c = let ps = class_parents c in if null ps then [] - else nub (ps ++ (concatMap class_allparents ps)) + else nub (ps <> (concatMap class_allparents ps)) getClassModuleBase :: Class -> String getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName) +getTClassModuleBase :: TemplateClass -> String +getTClassModuleBase = (<.>) <$> (cabal_moduleprefix.tclass_cabal) <*> (fst.hsTemplateClassName) + -- | Daughter map not including itself mkDaughterMap :: [Class] -> DaughterMap mkDaughterMap = foldl mkDaughterMapWorker M.empty @@ -529,65 +607,87 @@ ctypToHsTyp _c (CT CTCharStarStar _) = "(Ptr CString)" 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' +ctypToHsTyp _c (CPT (CPTClass c') _) = (fst . hsClassName) c' +ctypToHsTyp _c (CPT (CPTClassRef c') _) = (fst . hsClassName) c' +ctypToHsTyp _c (CPT (CPTClassCopy c') _) = (fst . hsClassName) c' +ctypToHsTyp _c (TemplateApp t p _) = "("<> tclass_name t <> " " <> p <> ")" +ctypToHsTyp _c (TemplateType t) = "("<> tclass_name t <> " " <> tclass_param t <> ")" +ctypToHsTyp _c (TemplateParam p) = "("<> p <> ")" +-- | +convertC2HS :: CTypes -> Type +convertC2HS CTString = tycon "CString" +convertC2HS CTChar = tycon "CChar" +convertC2HS CTInt = tycon "CInt" +convertC2HS CTUInt = tycon "CUInt" +convertC2HS CTLong = tycon "CLong" +convertC2HS CTULong = tycon "CULong" +convertC2HS CTDouble = tycon "CDouble" +convertC2HS CTDoubleStar = TyApp (tycon "Ptr") (tycon "CDouble") +convertC2HS CTBool = tycon "CInt" +convertC2HS CTVoidStar = TyApp (tycon "Ptr") unit_tycon +convertC2HS CTIntStar = TyApp (tycon "Ptr") (tycon "CInt") +convertC2HS CTCharStarStar = TyApp (tycon "Ptr") (tycon "CString") +convertC2HS (CPointer t) = TyApp (tycon "Ptr") (convertC2HS t) +convertC2HS (CRef t) = TyApp (tycon "Ptr") (convertC2HS t) + +-- | +convertCpp2HS :: Maybe Class -> Types -> Type +convertCpp2HS _c Void = unit_tycon +convertCpp2HS (Just c) SelfType = tycon ((fst.hsClassName) c) +convertCpp2HS Nothing SelfType = error "convertCpp2HS : SelfType but no class " +convertCpp2HS _c (CT t _) = convertC2HS t +convertCpp2HS _c (CPT (CPTClass c') _) = (tycon . fst . hsClassName) c' +convertCpp2HS _c (CPT (CPTClassRef c') _) = (tycon . fst . hsClassName) c' +convertCpp2HS _c (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c' +convertCpp2HS _c (TemplateApp t p _) = TyApp (tycon (tclass_name t)) (tycon p) +convertCpp2HS _c (TemplateType t) = TyApp (tycon (tclass_name t)) (mkTVar (tclass_param t)) +convertCpp2HS _c (TemplateParam p) = mkTVar p + +-- | +convertCpp2HS4Tmpl :: Type -> Maybe Class -> Type -> Types -> Type +convertCpp2HS4Tmpl _ _c _ Void = unit_tycon +convertCpp2HS4Tmpl _ (Just c) _ SelfType = tycon ((fst.hsClassName) c) +convertCpp2HS4Tmpl _ Nothing _ SelfType = error "convertCpp2HS4Tmpl : SelfType but no class " +convertCpp2HS4Tmpl _ _c _ (CT t _) = convertC2HS t +convertCpp2HS4Tmpl _ _c _ (CPT (CPTClass c') _) = (tycon . fst . hsClassName) c' +convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassRef c') _) = (tycon . fst . hsClassName) c' +convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c' +convertCpp2HS4Tmpl e _c _ (TemplateApp _ _ _ ) = e +convertCpp2HS4Tmpl e _c _ (TemplateType _) = e +convertCpp2HS4Tmpl _ _c t (TemplateParam _) = t + + + + typeclassName :: Class -> String typeclassName c = 'I' : fst (hsClassName c) +typeclassNameT :: TemplateClass -> String +typeclassNameT c = 'I' : fst (hsTemplateClassName c) + + + typeclassNameFromStr :: String -> String typeclassNameFromStr = ('I':) hsClassName :: Class -> (String, String) -- ^ High-level, 'Raw'-level hsClassName c = let cname = maybe (class_name c) id (class_alias c) - in (cname, "Raw" ++ cname) + in (cname, "Raw" <> cname) +hsTemplateClassName :: TemplateClass -> (String, String) -- ^ High-level, 'Raw'-level +hsTemplateClassName t = + let tname = tclass_name t + in (tname, "Raw" <> tname) + 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 - where (_hcname,rcname) = hsClassName c - selfstr = "(Ptr " ++ rcname ++ ")" - - hsargtype (CT ctype _) = hsCTypeName ctype - hsargtype (CPT x _) = hsCppTypeName x - hsargtype SelfType = selfstr - hsargtype _ = error "undefined hsargtype" - - hsrettype Void = "IO ()" - hsrettype SelfType = "IO " ++ selfstr - hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype - hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x - --- | 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] - - where (_hcname,rcname) = hsClassName c - selfstr = "(Ptr " ++ rcname ++ ")" - - hsargtype (CT ctype _) = hsCTypeName ctype - hsargtype (CPT x _) = hsCppTypeName x - hsargtype SelfType = selfstr - hsargtype _ = error "undefined hsargtype" - - hsrettype Void = "IO ()" - hsrettype SelfType = "IO " ++ selfstr - hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype - hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x - - hscFuncName :: Class -> Function -> String -hscFuncName c f = "c_" ++ toLowers (class_name c) ++ "_" ++ toLowers (aliasedFuncName c f) +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 @@ -596,15 +696,15 @@ hsFuncXformer :: Function -> String hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func) in if len > 0 - then "xform" ++ show (len - 1) + then "xform" <> show (len - 1) else "xformnull" hsFuncXformer func@(Static _ _ _ _) = let len = length (genericFuncArgs func) in if len > 0 - then "xform" ++ show (len - 1) + then "xform" <> show (len - 1) else "xformnull" hsFuncXformer func = let len = length (genericFuncArgs func) - in "xform" ++ show len + in "xform" <> show len genericFuncRet :: Function -> Types @@ -614,7 +714,6 @@ Virtual t _ _ _ -> t NonVirtual t _ _ _-> t Static t _ _ _ -> t - -- AliasVirtual t _ _ _ -> t Destructor _ -> void_ genericFuncArgs :: Function -> Args @@ -628,11 +727,10 @@ Virtual _ str _ a -> maybe str id a NonVirtual _ str _ a-> maybe (nonvirtualName c str) id a Static _ str _ a -> maybe (nonvirtualName c str) id a - -- AliasVirtual _ _ _ alias -> alias Destructor a -> maybe destructorName id a cppStaticName :: Class -> Function -> String -cppStaticName c f = class_name c ++ "::" ++ func_name f +cppStaticName c f = class_name c <> "::" <> func_name f cppFuncName :: Class -> Function -> String cppFuncName c f = case f of @@ -640,14 +738,144 @@ 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" + + +classConstraints :: Class -> Context +classConstraints = map ((\n->ClassA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents + +extractArgRetTypes :: Maybe Class -> Bool -> (Args,Types) -> ([Type],[Asst]) +extractArgRetTypes mc isvirtual (args,ret) = + let (typs,s) = flip runState ([],(0 :: Int)) $ do + as <- mapM (mktyp . fst) args + r <- case ret of + SelfType -> case mc of + Nothing -> error "extractArgRetTypes: SelfType return but no class" + Just c -> if isvirtual then return (mkTVar "a") else return $ tycon ((fst.hsClassName) c) + x -> (return . tycon . ctypToHsTyp Nothing) x + return (as ++ [TyApp (tycon "IO") r]) + in (typs,fst s) + where addclass c = do + (ctxts,n) <- get + let cname = (fst.hsClassName) c + iname = typeclassNameFromStr cname + tvar = mkTVar ('c' : show n) + ctxt1 = ClassA (unqual iname) [tvar] + ctxt2 = ClassA (unqual "FPtr") [tvar] + put (ctxt1:ctxt2:ctxts,n+1) + return tvar + addstring = do + (ctxts,n) <- get + let tvar = mkTVar ('c' : show n) + ctxt = ClassA (unqual "Castable") [tvar,tycon "CString"] + put (ctxt:ctxts,n+1) + return tvar + + mktyp typ = + case typ of + SelfType -> return (mkTVar "a") + CT CTString Const -> addstring + CT _ _ -> return $ tycon (ctypToHsTyp Nothing typ) + CPT (CPTClass c') _ -> addclass c' + CPT (CPTClassRef c') _ -> addclass c' + -- it is not clear whether the following is okay or not. + (TemplateApp t p _) -> return (TyApp (tycon (tclass_name t)) (tycon p)) + (TemplateType t) -> return (TyApp (tycon (tclass_name t)) (mkTVar (tclass_param t))) + (TemplateParam p) -> return (mkTVar p) + Void -> return unit_tycon + _ -> error ("No such c type : " <> show typ) + +functionSignature :: Class -> Function -> Type +functionSignature c f = + let (typs,ctxts) = extractArgRetTypes (Just c) (isVirtualFunc f) (genericFuncArgs f,genericFuncRet f) + arg0 + | isVirtualFunc f = (mkTVar "a" :) + | isNonVirtualFunc f = (mkTVar (class_name c) :) + | otherwise = id + in TyForall Nothing ctxts (foldr1 TyFun (arg0 typs)) + +functionSignatureT :: TemplateClass -> TemplateFunction -> Type +functionSignatureT t TFun {..} = + let (hname,_) = hsTemplateClassName t + tp = tclass_param t + ctyp = convertCpp2HS Nothing tfun_ret + arg0 = (TyApp (tycon hname) (mkTVar tp) :) + lst = arg0 (map (convertCpp2HS Nothing . fst) tfun_args) + in foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp]) +functionSignatureT t TFunNew {..} = + let ctyp = convertCpp2HS Nothing (TemplateType t) + lst = map (convertCpp2HS Nothing . fst) tfun_new_args + in foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp]) +functionSignatureT t TFunDelete = + let ctyp = convertCpp2HS Nothing (TemplateType t) + in ctyp `TyFun` (TyApp (tycon "IO") unit_tycon) + + + +functionSignatureTT :: TemplateClass -> TemplateFunction -> Type +functionSignatureTT t f = foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp]) + where + (hname,_) = hsTemplateClassName t + ctyp = case f of + TFun {..} -> convertCpp2HS4Tmpl e Nothing spl tfun_ret + TFunNew {..} -> convertCpp2HS4Tmpl e Nothing spl (TemplateType t) + TFunDelete -> unit_tycon + e = TyApp (tycon hname) spl + spl = TySplice (ParenSplice (mkVar (tclass_param t))) + lst = + case f of + TFun {..} -> e : map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_args + TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_new_args + TFunDelete -> [e] + + + +-- | this is for FFI type. +hsFFIFuncTyp :: Maybe (Selfness, Class) -> (Args,Types) -> Type +hsFFIFuncTyp msc (args,ret) = + foldr1 TyFun $ case msc of + Nothing -> argtyps <> [TyApp (tycon "IO") rettyp] + Just (Self,_) -> selftyp: argtyps <> [TyApp (tycon "IO") rettyp] + Just (NoSelf,_) -> argtyps <> [TyApp (tycon "IO") rettyp] + where argtyps = map (hsargtype . fst) args + rettyp = hsrettype ret + selftyp = case msc of + Just (_,c) -> TyApp tyPtr (tycon (snd (hsClassName c))) + Nothing -> error "hsFFIFuncTyp: no self for top level function" + hsargtype (CT ctype _) = tycon (hsCTypeName ctype) + hsargtype (CPT (CPTClass d) _) = TyApp tyPtr (tycon rawname) + where rawname = snd (hsClassName d) + hsargtype (CPT (CPTClassRef d) _) = TyApp tyPtr (tycon rawname) + where rawname = snd (hsClassName d) + hsargtype (TemplateApp t p _) = TyApp tyPtr (TyApp (tycon rawname) (tycon p)) + where rawname = snd (hsTemplateClassName t) + hsargtype (TemplateType t) = TyApp tyPtr (TyApp (tycon rawname) (mkTVar (tclass_param t))) + where rawname = snd (hsTemplateClassName t) + hsargtype (TemplateParam p) = mkTVar p + hsargtype SelfType = selftyp + hsargtype _ = error "hsFuncTyp: undefined hsargtype" + + hsrettype Void = unit_tycon + hsrettype SelfType = selftyp + hsrettype (CT ctype _) = tycon (hsCTypeName ctype) + hsrettype (CPT (CPTClass d) _) = TyApp tyPtr (tycon rawname) + where rawname = snd (hsClassName d) + hsrettype (CPT (CPTClassRef d) _) = TyApp tyPtr (tycon rawname) + where rawname = snd (hsClassName d) + hsrettype (CPT (CPTClassCopy d) _) = TyApp tyPtr (tycon rawname) + where rawname = snd (hsClassName d) + hsrettype (TemplateApp t p _) = TyApp tyPtr (TyApp (tycon rawname) (tycon p)) + where rawname = snd (hsTemplateClassName t) + hsrettype (TemplateType t) = TyApp tyPtr (TyApp (tycon rawname) (mkTVar (tclass_param t))) + where rawname = snd (hsTemplateClassName t) + hsrettype (TemplateParam p) = mkTVar p + diff --git a/lib/FFICXX/Generate/Type/Module.hs b/lib/FFICXX/Generate/Type/Module.hs --- a/lib/FFICXX/Generate/Type/Module.hs +++ b/lib/FFICXX/Generate/Type/Module.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Module --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -12,11 +12,53 @@ module FFICXX.Generate.Type.Module where -data Module = Module { module_name :: String - , module_exports :: [String] - } +import FFICXX.Generate.Type.Class +import FFICXX.Generate.Type.PackageInterface -mkModuleExports :: Module -> String -mkModuleExports _mod = "" --- "\n ( " ++ intercalate "\n , " (module_exports mod) ++ ")" +newtype Namespace = NS { unNamespace :: String } deriving (Show) + +data ClassImportHeader = ClassImportHeader + { cihClass :: Class + , cihSelfHeader :: HeaderName + , cihNamespace :: [Namespace] + , cihSelfCpp :: String + , cihIncludedHPkgHeadersInH :: [HeaderName] + , cihIncludedHPkgHeadersInCPP :: [HeaderName] + , cihIncludedCPkgHeaders :: [HeaderName] + } deriving (Show) + +data ClassModule = ClassModule + { cmModule :: String + , cmClass :: [Class] + , cmCIH :: [ClassImportHeader] + , cmImportedModulesHighNonSource :: [String] + , cmImportedModulesRaw :: [String] + , cmImportedModulesHighSource :: [String] + , cmImportedModulesForFFI :: [String] + , cmExtraImport :: [String] + } deriving (Show) + +data TemplateClassModule = TCM { tcmModule :: String + , tcmTemplateClasses :: [TemplateClass] + , tcmTCIH :: [TemplateClassImportHeader] + } deriving (Show) + + +data TemplateClassImportHeader = TCIH { tcihTClass :: TemplateClass + , tcihSelfHeader :: HeaderName + } deriving (Show) + +data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String + , tihClassDep :: [ClassImportHeader] + , tihFuncs :: [TopLevelFunction] + } deriving (Show) + +data PackageConfig = PkgConfig { pcfg_classModules :: [ClassModule] + , pcfg_classImportHeaders :: [ClassImportHeader] + , pcfg_topLevelImportHeader :: TopLevelImportHeader + , pcfg_templateClassModules :: [TemplateClassModule] + , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader] + } + + 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 @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.PackageInterface --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -27,9 +27,6 @@ instance IsString HeaderName where fromString = HdrName - - - type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName diff --git a/lib/FFICXX/Generate/Util.hs b/lib/FFICXX/Generate/Util.hs --- a/lib/FFICXX/Generate/Util.hs +++ b/lib/FFICXX/Generate/Util.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Util --- Copyright : (c) 2011-2013 Ian-Woo Kim +-- Copyright : (c) 2011-2016 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -13,21 +13,21 @@ module FFICXX.Generate.Util where - --- import Data.Char import Data.List -import Data.List.Split -import qualified Text.StringTemplate as ST --- --- import FFICXX.Generate.Type.CType --- +import Data.List.Split +import Data.Monoid ( (<>) ) +import Data.Text ( Text ) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text.Template + moduleDirFile :: String -> (String,String) moduleDirFile mname = let splitted = splitOn "." mname moddir = intercalate "/" (init splitted ) - modfile = (last splitted) ++ ".hs" + modfile = (last splitted) <> ".hs" in (moddir, modfile) hline :: IO () @@ -45,7 +45,7 @@ firstLower (x:xs) = (toLower x) : xs conn :: String -> String -> String -> String -conn st x y = x ++ st ++ y +conn st x y = x <> st <> y connspace :: String -> String -> String connspace = conn " " @@ -71,7 +71,6 @@ intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String intercalateWith f mapper x | not (null x) = foldl1 f (map mapper x) --- (foldl1 (\x1 y -> x1 `f` y) . (map mapper)) x | otherwise = "" @@ -81,33 +80,12 @@ return (foldl1 f ms) | otherwise = return "" --- intercalateM :: (Monad m) => String -> [String] -> m String --- intercalateM str = return . foldl1 (\x y-> x ++ str ++ y) +context :: [(Text,String)] -> Context +context assocs x = maybe err (T.pack) . lookup x $ assocs + where err = error $ "Could not find key: " <> (T.unpack x) -render :: String -> [(String,String)] -> String -render tmpl attribs = (ST.render . ST.setManyAttrib attribs . ST.newSTMP) tmpl - -- flip render1 - -renderTemplateGroup :: (ST.ToSElem a) => ST.STGroup String -> [(String,a)] - -> [Char] -> String -renderTemplateGroup gr attrs tmpl = - maybe ("template not found: " ++ tmpl) - (ST.toString . setManyAttribSafer attrs) - (ST.getStringTemplate tmpl gr) - -setManyAttribSafer :: (ST.Stringable b, ST.ToSElem a) => - [(String, a)] - -> ST.StringTemplate b - -> ST.StringTemplate b -setManyAttribSafer attrs st = - let mbFoundbadattr = find badTmplVarName . map fst $ attrs - in maybe (ST.setManyAttrib attrs st) - (\mbA -> ST.newSTMP . ("setManyAttribSafer, bad template atr: "++) - $ mbA) - mbFoundbadattr - where badTmplVarName :: String -> Bool - badTmplVarName t = not . null . filter (not . isAlpha) $ t - +subst :: Text -> Context -> String +subst t c = TL.unpack (substitute t c) diff --git a/lib/FFICXX/Generate/Util/HaskellSrcExts.hs b/lib/FFICXX/Generate/Util/HaskellSrcExts.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Util/HaskellSrcExts.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Util.HaskellSrcExts +-- Copyright : (c) 2011-2016 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- Stability : experimental +-- Portability : GHC +-- +----------------------------------------------------------------------------- + + +module FFICXX.Generate.Util.HaskellSrcExts where + +import Language.Haskell.Exts +import Language.Haskell.Exts.SrcLoc + +unqual :: String -> QName +unqual = UnQual . Ident + +tycon :: String -> Type +tycon = TyCon . unqual + +conDecl :: String -> [Type] -> ConDecl +conDecl n ys = ConDecl (Ident n) ys + +recDecl :: String -> [([Name],Type)] -> ConDecl +recDecl n rs = RecDecl (Ident n) rs + +app :: String -> String -> Exp +app x y = App (mkVar x) (mkVar y) + +mkVar :: String -> Exp +mkVar = Var . unqual + +con :: String -> Exp +con = Con . unqual + +mkTVar :: String -> Type +mkTVar = TyVar . Ident + +mkPVar :: String -> Pat +mkPVar = PVar . Ident + +mkPVarSig :: String -> Type -> Pat +mkPVarSig n typ = PatTypeSig noLoc (mkPVar n) typ + +pbind :: Pat -> Exp -> Maybe Binds -> Decl +pbind pat e = PatBind noLoc pat (UnGuardedRhs e) + +mkTBind :: String -> TyVarBind +mkTBind = UnkindedVar . Ident + +mkBind1 :: String -> [Pat] -> Exp -> Maybe Binds -> Decl +mkBind1 n pat rhs mbinds = + FunBind [ Match noLoc (Ident n) pat Nothing (UnGuardedRhs rhs) mbinds ] + +mkFun :: String -> Type -> [Pat] -> Exp -> Maybe Binds -> [Decl] +mkFun fname typ pats rhs mbinds = [mkFunSig fname typ, mkBind1 fname pats rhs mbinds] + +mkFunSig :: String -> Type -> Decl +mkFunSig fname typ = TypeSig noLoc [Ident fname] typ + +mkClass :: Context -> String -> [TyVarBind] -> [ClassDecl] -> Decl +mkClass ctxt n tbinds cdecls = ClassDecl noLoc ctxt (Ident n) tbinds [] cdecls + +mkInstance :: Context -> String -> [Type] -> [InstDecl] -> Decl +mkInstance ctxt n typs idecls = InstDecl noLoc Nothing [] ctxt (unqual n) typs idecls + +mkData :: String -> [TyVarBind] -> [QualConDecl] -> [Deriving] -> Decl +mkData n tbinds qdecls derivs = DataDecl noLoc DataType [] (Ident n) tbinds qdecls derivs + +mkNewtype :: String -> [TyVarBind] -> [QualConDecl] -> [Deriving] -> Decl +mkNewtype n tbinds qdecls derivs = DataDecl noLoc NewType [] (Ident n) tbinds qdecls derivs + +mkForImpCcall :: String -> String -> Type -> Decl +mkForImpCcall quote n typ = ForImp noLoc CCall (PlaySafe False) quote (Ident n) typ + +mkModule :: String -> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module +mkModule n pragmas idecls decls = Module noLoc (ModuleName n) pragmas Nothing Nothing idecls decls + +mkModuleE :: String -> [ModulePragma] -> [ExportSpec] -> [ImportDecl] -> [Decl] -> Module +mkModuleE n pragmas exps idecls decls = Module noLoc (ModuleName n) pragmas Nothing (Just exps) idecls decls + +mkImport :: String -> ImportDecl +mkImport m = ImportDecl noLoc (ModuleName m) False False False Nothing Nothing Nothing + +mkImportExp :: String -> [String] -> ImportDecl +mkImportExp m lst = ImportDecl noLoc (ModuleName m) False False False Nothing Nothing + (Just (False,map (IVar . Ident) lst)) + +mkImportSrc :: String -> ImportDecl +mkImportSrc m = ImportDecl noLoc (ModuleName m) False True False Nothing Nothing Nothing + +lang :: [String] -> ModulePragma +lang ns = LanguagePragma noLoc (map Ident ns) + +dot :: Exp -> Exp -> Exp +x `dot` y = x `App` mkVar "." `App` y + +tyPtr :: Type +tyPtr = tycon "Ptr" + +tyForeignPtr :: Type +tyForeignPtr = tycon "ForeignPtr" + diff --git a/lib/FFICXX/Paths_fficxx.hs b/lib/FFICXX/Paths_fficxx.hs deleted file mode 100644 --- a/lib/FFICXX/Paths_fficxx.hs +++ /dev/null @@ -1,6 +0,0 @@ -module FFICXX.Paths_fficxx ( - module Paths_fficxx - ) where - -import Paths_fficxx - 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.Module import FFICXX.Generate.Type.PackageInterface snappyclasses = [ ] @@ -71,19 +72,19 @@ 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"])) + , ("UncheckedByteArraySink", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"])) ] mycabalattr = CabalAttr - { cabalattr_license = Nothing - , cabalattr_licensefile = Nothing + { cabalattr_license = Just "BSD3" + , cabalattr_licensefile = Just "LICENSE" , cabalattr_extraincludedirs = [] , cabalattr_extralibdirs = [] } main :: IO () main = do - simpleBuilder "Snappy" headerMap (mycabal,mycabalattr,myclasses,toplevelfunctions) [ "snappy" ] + simpleBuilder "Snappy" headerMap (mycabal,mycabalattr,myclasses,toplevelfunctions,[]) [ "snappy" ] [] diff --git a/template/Cast.hs.st b/template/Cast.hs.st deleted file mode 100644 --- a/template/Cast.hs.st +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies, - MultiParamTypeClasses, OverlappingInstances, IncoherentInstances #-} - -$castHeader$ - -import Foreign.Ptr -import Foreign.ForeignPtr (castForeignPtr, newForeignPtr_) -import Foreign.ForeignPtr.Unsafe -import FFICXX.Runtime.Cast -import System.IO.Unsafe - -$castImport$ - -$castBody$ diff --git a/template/Class.hs-boot.st b/template/Class.hs-boot.st deleted file mode 100644 --- a/template/Class.hs-boot.st +++ /dev/null @@ -1,3 +0,0 @@ -module $moduleName$ where - -$hsBootBody$ diff --git a/template/Existential.hs.st b/template/Existential.hs.st deleted file mode 100644 --- a/template/Existential.hs.st +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE TypeFamilies, GADTs, ExistentialQuantification, EmptyDataDecls #-} - --- module HROOT.Class.Existential where - -$existHeader$ - - ---import Foreign.C -import Foreign.ForeignPtr ---import Foreign.Marshal.Array -import HROOT.TypeCast -import HROOT.Class.TClass.RawType -import HROOT.Class.TClass.Interface -import HROOT.Class.TClass.Cast -import HROOT.Class.TClass.Implementation -import HROOT.Class.TObject.RawType -import HROOT.Class.TObject.Interface -import HROOT.Class.TObject.Cast -import HROOT.Class.TObject.Implementation - -$existImport$ - --- import HROOT.Class.$modname$.Interface --- import HROOT.Class.$modname$.Implementation () - -$existEachBody$ - - diff --git a/template/ExistentialEach.hs.st b/template/ExistentialEach.hs.st deleted file mode 100644 --- a/template/ExistentialEach.hs.st +++ /dev/null @@ -1,19 +0,0 @@ -instance GADTTypeable $mother$ where - data GADTType $mother$ a where -$GADTbody$ - GADT$mother$Bottom :: GADTType $mother$ BottomType - data EGADTType $mother$ = forall a. EGADT$mother$ (GADTType $mother$ a) - -cast$mother$ :: Exist $mother$ -> IO (EGADTType $mother$) -cast$mother$ eobj = do - let obj = $mother$ (get_fptr eobj) - tclass <- isA obj - cname <- getName tclass - case cname of -$castbody$ - _ -> return . EGADT$mother$ \$ GADT$mother$Bottom - - - - - diff --git a/template/FFI.hsc.st b/template/FFI.hsc.st deleted file mode 100644 --- a/template/FFI.hsc.st +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - --- module HROOT.Class.FFI where - -$ffiHeader$ - -import Foreign.C -import Foreign.Ptr - --- import HROOT.Class.Interface - --- #include "$headerFileName$" - -$ffiImport$ - -$cppInclude$ - -$hsFunctionBody$ - diff --git a/template/Implementation.hs.st b/template/Implementation.hs.st deleted file mode 100644 --- a/template/Implementation.hs.st +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, - FlexibleInstances, TypeSynonymInstances, EmptyDataDecls, - OverlappingInstances, IncoherentInstances #-} - -$implHeader$ - -import FFICXX.Runtime.Cast - -$implImport$ - -import Data.Word -import Foreign.C -import Foreign.Ptr -import Foreign.ForeignPtr - -import System.IO.Unsafe - - -$implBody$ diff --git a/template/Interface.hs.st b/template/Interface.hs.st deleted file mode 100644 --- a/template/Interface.hs.st +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, - FlexibleInstances, TypeSynonymInstances, - EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-} - --- module HROOT.Class.Interface where - -$ifaceHeader$ - -import Data.Word -import Foreign.C -import Foreign.Ptr -import Foreign.ForeignPtr -import FFICXX.Runtime.Cast - -$ifaceImport$ - -$ifaceBody$ diff --git a/template/Module.h.st b/template/Module.h.st deleted file mode 100644 --- a/template/Module.h.st +++ /dev/null @@ -1,18 +0,0 @@ -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef $typemacro$ -#define $typemacro$ - -#include "$cprefix$Type.h" - -$declarationheader$ - -$declarationbody$ - -#endif // $typemacro$ - -#ifdef __cplusplus -} -#endif diff --git a/template/Pkg.cabal.st b/template/Pkg.cabal.st deleted file mode 100644 --- a/template/Pkg.cabal.st +++ /dev/null @@ -1,42 +0,0 @@ -Name: $pkgname$ -Version: $version$ -Synopsis: $synopsis$ -Description: $description$ -Homepage: $homepage$ -$licenseField$ -$licenseFileField$ -Author: $author$ -Maintainer: $maintainer$ -Category: $category$ -Tested-with: GHC >= 7.6 -Build-Type: $buildtype$ -cabal-version: >=1.10 -Extra-source-files: -$cabalIndentation$CHANGES -$cabalIndentation$Config.hs -$csrcFiles$ - -$sourcerepository$ - -Library - default-language: Haskell2010 - hs-source-dirs: src - ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports - ghc-prof-options: -caf-all -auto-all - cc-options: $ccOptions$ - Build-Depends: base>4 && < 5, fficxx-runtime >= 0.2 $deps$ - Exposed-Modules: -$exposedModules$ - Other-Modules: -$otherModules$ - extra-lib-dirs: $extralibdirs$ - extra-libraries: stdc++ $extraLibraries$ - Include-dirs: csrc $extraincludedirs$ - Install-includes: -$includeFiles$ - C-sources: -$cppFiles$ - - - - diff --git a/template/Pkg.cpp.st b/template/Pkg.cpp.st deleted file mode 100644 --- a/template/Pkg.cpp.st +++ /dev/null @@ -1,38 +0,0 @@ -#include - -$header$ - -using namespace std; -$namespace$ - -template -const ToType* to_const(const FromType* x) { - return reinterpret_cast(x); -} - -template -ToType* to_nonconst(FromType* x) { - return reinterpret_cast(x); -} - -template -const ToType& to_constref(const FromType& x) { - return reinterpret_cast(x); -} - -template -ToType& to_nonconstref(FromType& x) { - return reinterpret_cast(x); -} - - -#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED) - -#define TYPECASTMETHOD(cname,mname,oname) \\ - IIF( CHECKPROTECT(cname,mname) ) ( \\ - (to_nonconst), \\ - (to_nonconst) ) - -$cppbody$ - - diff --git a/template/Pkg.hs.st b/template/Pkg.hs.st deleted file mode 100644 --- a/template/Pkg.hs.st +++ /dev/null @@ -1,7 +0,0 @@ -module $summarymod$ ( -$exportList$ -) where - -$importList$ - -$topLevelDef$ diff --git a/template/PkgType.h.st b/template/PkgType.h.st deleted file mode 100644 --- a/template/PkgType.h.st +++ /dev/null @@ -1,14 +0,0 @@ -#ifdef __cplusplus -extern "C" { -#endif - -#ifndef $typemacro$ -#define $typemacro$ - -$typeDeclBody$ - -#endif // $typemacro$ - -#ifdef __cplusplus -} -#endif diff --git a/template/RawType.hs.st b/template/RawType.hs.st deleted file mode 100644 --- a/template/RawType.hs.st +++ /dev/null @@ -1,10 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, - FlexibleInstances, TypeSynonymInstances, - EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-} - -$rawtypeHeader$ - -import Foreign.ForeignPtr -import FFICXX.Runtime.Cast - -$rawtypeBody$ diff --git a/template/classdef.cpp.st b/template/classdef.cpp.st deleted file mode 100644 --- a/template/classdef.cpp.st +++ /dev/null @@ -1,3 +0,0 @@ -#undef ROOT_$classname$_DEFINITION -#define ROOT_$classname$_DEFINITION(Type) \\ -$funcdef$ diff --git a/template/declbody.h.st b/template/declbody.h.st deleted file mode 100644 --- a/template/declbody.h.st +++ /dev/null @@ -1,4 +0,0 @@ -#undef ROOT_$classname$_DECLARATION -#define ROOT_$classname$_DECLARATION \\ - $funcdecl$ - diff --git a/template/funcdecl.h.st b/template/funcdecl.h.st deleted file mode 100644 --- a/template/funcdecl.h.st +++ /dev/null @@ -1,1 +0,0 @@ -$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ ) diff --git a/template/function.cpp.st b/template/function.cpp.st deleted file mode 100644 --- a/template/function.cpp.st +++ /dev/null @@ -1,4 +0,0 @@ -$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ ) \\ -{ \\ - $funcbody$ \\ -} diff --git a/template/functionbody.cpp.st b/template/functionbody.cpp.st deleted file mode 100644 --- a/template/functionbody.cpp.st +++ /dev/null @@ -1,1 +0,0 @@ -to_nonconst(p) -> $funcname$ ( $args$ ) ; diff --git a/template/module.hs.st b/template/module.hs.st deleted file mode 100644 --- a/template/module.hs.st +++ /dev/null @@ -1,8 +0,0 @@ -module $moduleName$ - ( -$exportList$ - ) where - -$importList$ - -