fficxx 0.4.1 → 0.5
raw patch · 30 files changed
+2983/−2228 lines, 30 filesdep +aesondep +aeson-pretty
Dependencies added: aeson, aeson-pretty
Files
- fficxx.cabal +38/−37
- lib/FFICXX/Generate/Builder.hs +136/−103
- lib/FFICXX/Generate/Code/Cabal.hs +174/−92
- lib/FFICXX/Generate/Code/Cpp.hs +371/−116
- lib/FFICXX/Generate/Code/Dependency.hs +0/−266
- lib/FFICXX/Generate/Code/HsCast.hs +37/−0
- lib/FFICXX/Generate/Code/HsFFI.hs +64/−24
- lib/FFICXX/Generate/Code/HsFrontEnd.hs +141/−203
- lib/FFICXX/Generate/Code/HsTemplate.hs +180/−0
- lib/FFICXX/Generate/Code/MethodDef.hs +0/−157
- lib/FFICXX/Generate/Code/Primitive.hs +814/−0
- lib/FFICXX/Generate/ContentMaker.hs +219/−179
- lib/FFICXX/Generate/Dependency.hs +430/−0
- lib/FFICXX/Generate/Name.hs +140/−0
- lib/FFICXX/Generate/Type/Cabal.hs +83/−0
- lib/FFICXX/Generate/Type/Class.hs +77/−738
- lib/FFICXX/Generate/Type/Config.hs +25/−0
- lib/FFICXX/Generate/Type/Module.hs +29/−19
- lib/FFICXX/Generate/Type/PackageInterface.hs +3/−1
- lib/FFICXX/Generate/Util.hs +12/−4
- lib/FFICXX/Generate/Util/HaskellSrcExts.hs +10/−12
- sample/cxxlib/Makefile +0/−10
- sample/cxxlib/include/A.h +0/−13
- sample/cxxlib/include/B.h +0/−13
- sample/cxxlib/src/A.cpp +0/−16
- sample/cxxlib/src/B.cpp +0/−15
- sample/mysample-generator/MySampleGen.hs +0/−52
- sample/mysample-generator/use_mysample.hs +0/−16
- sample/snappy-generator/SnappyGen.hs +0/−91
- sample/snappy-generator/testSnappy.hs +0/−51
fficxx.cabal view
@@ -1,5 +1,5 @@ Name: fficxx-Version: 0.4.1+Version: 0.5 Synopsis: automatic C++ binding generation Description: automatic C++ binding generation License: BSD3@@ -9,14 +9,6 @@ Build-Type: Simple Category: FFI Tools Cabal-Version: >= 1.8-Data-files: - sample/cxxlib/include/*.h- sample/cxxlib/src/*.cpp- sample/cxxlib/Makefile- sample/mysample-generator/MySampleGen.hs- sample/mysample-generator/use_mysample.hs- sample/snappy-generator/SnappyGen.hs- sample/snappy-generator/testSnappy.hs Source-repository head type: git@@ -24,47 +16,56 @@ Library hs-source-dirs: lib- ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind- ghc-prof-options: -caf-all -auto-all- Build-Depends: base == 4.*,- Cabal,- bytestring,- containers,- data-default,- directory,- either,- errors,- filepath>1,- hashable,- haskell-src-exts >= 1.18,- lens > 3,- mtl>2,- process,- pureMD5,- split,- transformers >= 0.3,- template,- template-haskell,- text,- unordered-containers- + Build-Depends: base == 4.*+ , aeson+ , aeson-pretty+ , bytestring+ , Cabal+ , containers+ , data-default+ , directory+ , either+ , errors+ , filepath>1+ , hashable+ , haskell-src-exts >= 1.18+ , lens > 3+ , mtl>2+ , process+ , pureMD5+ , split+ , transformers >= 0.3+ , template+ , template-haskell+ , text+ , unordered-containers + Exposed-Modules: FFICXX.Generate.Builder FFICXX.Generate.Config- FFICXX.Generate.Code.MethodDef FFICXX.Generate.Code.Cpp+ FFICXX.Generate.Code.HsCast FFICXX.Generate.Code.HsFrontEnd FFICXX.Generate.Code.HsFFI+ FFICXX.Generate.Code.HsTemplate FFICXX.Generate.Code.Cabal- FFICXX.Generate.Code.Dependency+ FFICXX.Generate.Code.Primitive FFICXX.Generate.ContentMaker+ FFICXX.Generate.Dependency+ FFICXX.Generate.Name FFICXX.Generate.QQ.Verbatim FFICXX.Generate.Util FFICXX.Generate.Util.HaskellSrcExts FFICXX.Generate.Type.Annotate+ FFICXX.Generate.Type.Cabal+ FFICXX.Generate.Type.Config FFICXX.Generate.Type.Class FFICXX.Generate.Type.Module FFICXX.Generate.Type.PackageInterface--+ ghc-options: -Wall+ -funbox-strict-fields+ -fno-warn-unused-do-bind+ -fno-warn-missing-signatures+ -O2+ ghc-prof-options: -caf-all -auto-all
lib/FFICXX/Generate/Builder.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Builder--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,25 +15,28 @@ module FFICXX.Generate.Builder where -import Control.Monad ( forM_, void, when )+import Control.Monad (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 Data.Char (toUpper)+import Data.Digest.Pure.MD5 (md5)+import Data.Foldable (for_)+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.Dependency+import FFICXX.Generate.Dependency import FFICXX.Generate.Config import FFICXX.Generate.ContentMaker-import FFICXX.Generate.Type.Class -import FFICXX.Generate.Type.Module +import FFICXX.Generate.Type.Cabal (Cabal(..),CabalName(..)+ ,AddCInc(..),AddCSrc(..))+import FFICXX.Generate.Type.Config (ModuleUnitMap(..))+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface import FFICXX.Generate.Util --@@ -41,177 +44,209 @@ macrofy :: String -> String macrofy = map ((\x->if x=='-' then '_' else x) . toUpper) -simpleBuilder :: String -> [(String,([Namespace],[HeaderName]))]- -> (Cabal, CabalAttr, [Class], [TopLevelFunction], [(TemplateClass,HeaderName)])+simpleBuilder :: String+ -> ModuleUnitMap+ -> (Cabal, [Class], [TopLevelFunction], [(TemplateClass,HeaderName)]) -> [String] -- ^ extra libs -> [(String,[String])] -- ^ extra module -> IO ()-simpleBuilder summarymodule lst (cabal, cabalattr, classes, toplevelfunctions, templates) extralibs extramods = do+simpleBuilder topLevelMod mumap (cabal,classes,toplevelfunctions,templates) extralibs extramods = do+ putStrLn "----------------------------------------------------"+ putStrLn "-- fficxx code generation for Haskell-C++ binding --"+ putStrLn "----------------------------------------------------"+ let pkgname = cabal_pkgname cabal- putStrLn ("generating " <> pkgname)+ putStrLn ("Generating " <> unCabalName pkgname) cwd <- getCurrentDirectory let cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd , fficxxconfig_workingDir = cwd </> "working"- , fficxxconfig_installBaseDir = cwd </> pkgname+ , fficxxconfig_installBaseDir = cwd </> unCabalName pkgname } workingDir = fficxxconfig_workingDir cfg installDir = fficxxconfig_installBaseDir cfg pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) = mkPackageConfig- (pkgname, mkClassNSHeaderFromMap (HM.fromList lst))+ (pkgname, findModuleUnitImports mumap) (classes, toplevelfunctions,templates,extramods) (cabal_additional_c_incs cabal) (cabal_additional_c_srcs cabal) hsbootlst = mkHSBOOTCandidateList mods- cabalFileName = pkgname <.> "cabal" + cabalFileName = unCabalName pkgname <.> "cabal"+ jsonFileName = unCabalName pkgname <.> "json" -- notExistThenCreate workingDir notExistThenCreate installDir notExistThenCreate (installDir </> "src") notExistThenCreate (installDir </> "csrc") --- putStrLn "cabal file generation"- buildCabalFile (cabal,cabalattr) summarymodule pkgconfig extralibs (workingDir</>cabalFileName)+ putStrLn "Generating Cabal file"+ buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDir</>cabalFileName) --- putStrLn "header file generation"- let typmacro = TypMcro ("__" <> macrofy (cabal_pkgname cabal) <> "__")+ putStrLn "Generating JSON file"+ buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDir</>jsonFileName)+ --+ putStrLn "Generating Header file"+ let typmacro = TypMcro ("__" <> macrofy (unCabalName (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 ->+ gen (unCabalName pkgname <> "Type.h") (buildTypeDeclHeader typmacro (map cihClass cihs))+ for_ cihs $ \hdr -> gen+ (unHdrName (cihSelfHeader hdr))+ (buildDeclHeader typmacro (unCabalName pkgname) hdr)+ gen+ (tihHeaderFileName tih <.> "h")+ (buildTopLevelHeader typmacro (unCabalName pkgname) tih)+ for_ tcms $ \m -> let tcihs = tcmTCIH m- in forM_ tcihs $ \tcih ->+ in for_ tcihs $ \tcih -> let t = tcihTClass tcih hdr = unHdrName (tcihSelfHeader tcih) in gen hdr (buildTemplateHeader typmacro t) --- putStrLn "cpp file generation"- mapM_ (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) cihs- gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelFunctionCppDef tih)+ putStrLn "Generating Cpp file"+ for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr))+ gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih) --- putStrLn "additional header/source generation"- mapM_ (\(AddCInc hdr txt) -> gen hdr txt) (cabal_additional_c_incs cabal)- mapM_ (\(AddCSrc hdr txt) -> gen hdr txt) (cabal_additional_c_srcs cabal)- -- - putStrLn "RawType.hs file generation"- mapM_ (\m -> gen (cmModule m <.> "RawType" <.> "hs") (prettyPrint (buildRawTypeHs m))) mods+ putStrLn "Generating Additional Header/Source"+ for_ (cabal_additional_c_incs cabal) (\(AddCInc hdr txt) -> gen hdr txt)+ for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt) --- putStrLn "FFI.hsc file generation"- mapM_ (\m -> gen (cmModule m <.> "FFI" <.> "hsc") (prettyPrint (buildFFIHsc m))) mods+ putStrLn "Generating RawType.hs"+ for_ mods $ \m -> gen+ (cmModule m <.> "RawType" <.> "hs")+ (prettyPrint (buildRawTypeHs m)) --- putStrLn "Interface.hs file generation"- mapM_ (\m -> gen (cmModule m <.> "Interface" <.> "hs") (prettyPrint (buildInterfaceHs mempty m))) mods+ putStrLn "Generating FFI.hsc"+ for_ mods $ \m -> gen+ (cmModule m <.> "FFI" <.> "hsc")+ (prettyPrint (buildFFIHsc m)) --- putStrLn "Cast.hs file generation"- mapM_ (\m -> gen (cmModule m <.> "Cast" <.> "hs") (prettyPrint (buildCastHs m))) mods+ putStrLn "Generating Interface.hs"+ for_ mods $ \m -> gen+ (cmModule m <.> "Interface" <.> "hs")+ (prettyPrint (buildInterfaceHs mempty m)) --- putStrLn "Implementation.hs file generation"- mapM_ (\m -> gen (cmModule m <.> "Implementation" <.> "hs") (prettyPrint (buildImplementationHs mempty m))) mods+ putStrLn "Generating Cast.hs"+ for_ mods $ \m -> gen+ (cmModule m <.> "Cast" <.> "hs")+ (prettyPrint (buildCastHs m)) --- 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_ (\m -> gen (m <.> "Interface" <.> "hs-boot") (prettyPrint (buildInterfaceHSBOOT m))) hsbootlst+ putStrLn "Generating Implementation.hs"+ for_ mods $ \m -> gen+ (cmModule m <.> "Implementation" <.> "hs")+ (prettyPrint (buildImplementationHs mempty m)) ---+ putStrLn "Generating Template.hs"+ for_ tcms $ \m -> gen+ (tcmModule m <.> "Template" <.> "hs")+ (prettyPrint (buildTemplateHs m))+ --+ putStrLn "Generating TH.hs"+ for_ tcms $ \m -> gen+ (tcmModule m <.> "TH" <.> "hs")+ (prettyPrint (buildTHHs m)) - - putStrLn "module file generation"- mapM_ (\m -> gen (cmModule m <.> "hs") (prettyPrint (buildModuleHs m))) mods --- putStrLn "summary module generation generation"- gen (summarymodule <.> "hs") (buildPkgHs summarymodule (mods,tcms) tih)+ -- TODO: Template.hs-boot need to be generated as well+ putStrLn "Generating hs-boot file"+ for_ hsbootlst $ \m -> gen+ (m <.> "Interface" <.> "hs-boot")+ (prettyPrint (buildInterfaceHSBOOT m)) --- putStrLn "copying"+ putStrLn "Generating Module summary file"+ for_ mods $ \m -> gen+ (cmModule m <.> "hs")+ (prettyPrint (buildModuleHs m))+ --+ putStrLn "Generating Top-level Module"+ gen (topLevelMod <.> "hs") (prettyPrint (buildTopLevelHs topLevelMod (mods,tcms) tih))+ --+ putStrLn "Copying generated files to target directory" touch (workingDir </> "LICENSE") copyFileWithMD5Check (workingDir </> cabalFileName) (installDir </> cabalFileName)+ copyFileWithMD5Check (workingDir </> jsonFileName) (installDir </> jsonFileName) copyFileWithMD5Check (workingDir </> "LICENSE") (installDir </> "LICENSE") - copyCppFiles workingDir (csrcDir installDir) pkgname pkgconfig- mapM_ (copyModule workingDir (srcDir installDir)) mods- mapM_ (copyTemplateModule workingDir (srcDir installDir)) tcms - moduleFileCopy workingDir (srcDir installDir) $ summarymodule <.> "hs"+ copyCppFiles workingDir (csrcDir installDir) (unCabalName pkgname) pkgconfig+ for_ mods (copyModule workingDir (srcDir installDir))+ for_ tcms (copyTemplateModule workingDir (srcDir installDir))+ moduleFileCopy workingDir (srcDir installDir) $ topLevelMod <.> "hs" + putStrLn "----------------------------------------------------"+ putStrLn "-- Code generation has been completed. Enjoy! --"+ putStrLn "----------------------------------------------------" + -- | some dirty hack. later, we will do it with more proper approcah. touch :: FilePath -> IO () touch fp = void (readProcess "touch" [fp] "") -notExistThenCreate :: FilePath -> IO () -notExistThenCreate dir = do +notExistThenCreate :: FilePath -> IO ()+notExistThenCreate dir = do b <- doesDirectoryExist dir if b then return () else system ("mkdir -p " <> dir) >> return () -copyFileWithMD5Check :: FilePath -> FilePath -> IO () +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 + 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 acincs acsrcs) = do +copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs acincs acsrcs) = do let thfile = cprefix <> "Type.h" tlhfile = tihHeaderFileName tih <.> "h" tlcppfile = tihHeaderFileName tih <.> "cpp"- copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile) - doesFileExist (wdir </> tlhfile) + copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile)+ doesFileExist (wdir </> tlhfile) >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))- doesFileExist (wdir </> tlcppfile) + doesFileExist (wdir </> tlcppfile) >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))- forM_ cihs $ \header-> do + for_ cihs $ \header-> do let hfile = unHdrName (cihSelfHeader header) cppfile = cihSelfCpp header- copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) + copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile) - forM_ tcihs $ \header-> do + for_ tcihs $ \header-> do let hfile = unHdrName (tcihSelfHeader header)- copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) + copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) - forM_ acincs $ \(AddCInc header _) -> + for_ acincs $ \(AddCInc header _) -> copyFileWithMD5Check (wdir </> header) (ddir </> header) - forM_ acsrcs $ \(AddCSrc csrc _) -> + for_ acsrcs $ \(AddCSrc csrc _) -> copyFileWithMD5Check (wdir </> csrc) (ddir </> csrc) moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO ()-moduleFileCopy wdir ddir fname = do +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 + 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 -+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"@@ -219,12 +254,10 @@ 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 +copyTemplateModule wdir ddir m = do+ let modbase = tcmModule m moduleFileCopy wdir ddir $ modbase <> ".Template.hs" moduleFileCopy wdir ddir $ modbase <> ".TH.hs"- return ()-
lib/FFICXX/Generate/Code/Cabal.hs view
@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}-+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cabal--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,102 +14,125 @@ module FFICXX.Generate.Code.Cabal where -import Data.List ( intercalate, nub )-import Data.Monoid ( (<>) )-import Data.Text ( Text )-import System.FilePath ( (<.>), (</>) )+import Data.Aeson.Encode.Pretty (encodePretty)+import qualified Data.ByteString.Lazy as BL+import Data.List (intercalate,nub)+import Data.Monoid ((<>))+import Data.Text (Text)+import Data.Text.Template (substitute)+import qualified Data.Text as T (intercalate,pack,replicate,unlines)+import qualified Data.Text.Lazy as TL (toStrict)+import qualified Data.Text.IO as TIO (writeFile)+import System.FilePath ((<.>),(</>)) ---import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface-import FFICXX.Generate.Util+import FFICXX.Generate.Type.Cabal (AddCInc(..),AddCSrc(..)+ ,CabalName(..),Cabal(..)+ ,GeneratedCabalInfo(..))+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Type.PackageInterface+import FFICXX.Generate.Util -cabalIndentation :: String -cabalIndentation = replicate 23 ' ' +cabalIndentation :: Text -- String+cabalIndentation = T.replicate 23 " " +unlinesWithIndent = T.unlines . map (cabalIndentation <>)+ -- for source distribution genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> [AddCInc] -> [AddCSrc]- -> String+ -> [String] genCsrcFiles (tih,cmods) acincs acsrcs =- let indent = cabalIndentation - selfheaders' = do + let -- indent = cabalIndentation+ selfheaders' = do x <- cmods y <- cmCIH x- return (cihSelfHeader y) + return (cihSelfHeader y) selfheaders = nub selfheaders'- selfcpp' = do + selfcpp' = do x <- cmods- y <- cmCIH x + y <- cmCIH x return (cihSelfCpp y)- selfcpp = nub selfcpp' + selfcpp = nub selfcpp' tlh = tihHeaderFileName tih <.> "h" tlcpp = tihHeaderFileName tih <.> "cpp"- includeFileStrsWithCsrc = map (\x->indent<>"csrc"</> x) $ + includeFileStrsWithCsrc = map (\x->"csrc"</> x) $ (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders)) ++ map (\(AddCInc hdr _) -> hdr) acincs- cppFilesWithCsrc = map (\x->indent<>"csrc"</>x) $+ cppFilesWithCsrc = map (\x->"csrc"</>x) $ (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) ++ map (\(AddCSrc src _) -> src) acsrcs - - in unlines (includeFileStrsWithCsrc <> cppFilesWithCsrc) + in includeFileStrsWithCsrc <> cppFilesWithCsrc -- for library-genIncludeFiles :: String -- ^ package name +genIncludeFiles :: String -- ^ package name -> ([ClassImportHeader],[TemplateClassImportHeader]) -> [AddCInc]- -> String+ -> [String] genIncludeFiles pkgname (cih,tcih) acincs =- let indent = cabalIndentation + let -- indent = cabalIndentation selfheaders = map cihSelfHeader cih <> map tcihSelfHeader tcih- includeFileStrs = map ((indent<>).unHdrName) (selfheaders ++ map (\(AddCInc hdr _) -> HdrName hdr) acincs)- in unlines ((indent<>pkgname<>"Type.h") : includeFileStrs)+ includeFileStrs = map unHdrName (selfheaders ++ map (\(AddCInc hdr _) -> HdrName hdr) acincs)+ in (pkgname<>"Type.h") : includeFileStrs +-- unlines ((indent<>++ -- for library genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> [AddCSrc]- -> String -genCppFiles (tih,cmods) acsrcs = - let indent = cabalIndentation - selfcpp' = do + -> [String]+genCppFiles (tih,cmods) acsrcs =+ let -- indent = cabalIndentation+ selfcpp' = do x <- cmods y <- cmCIH x- return (cihSelfCpp y) + return (cihSelfCpp y) selfcpp = nub selfcpp' tlcpp = tihHeaderFileName tih <.> "cpp"- cppFileStrs = map (\x->indent<> "csrc" </> x) $ + cppFileStrs = map (\x -> "csrc" </> x) $ (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) ++ map (\(AddCSrc src _) -> src) acsrcs- in unlines cppFileStrs + in cppFileStrs --- | generate exposed module list in cabal file -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- 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 exposed module list in cabal file+genExposedModules :: String -> ([ClassModule],[TemplateClassModule]) -> [String]+genExposedModules summarymod (cmods,tmods) =+ let -- indentspace = cabalIndentation+ -- summarystrs = summarymod+ cmodstrs = map cmModule cmods+ rawType = map ((\x -> x <> ".RawType").cmModule) cmods+ ffi = map ((\x -> x <> ".FFI").cmModule) cmods+ interface= map ((\x-> x <> ".Interface").cmModule) cmods+ cast = map ((\x-> x <> ".Cast").cmModule) cmods+ implementation = map ((\x-> x <> ".Implementation").cmModule) cmods+ template = map ((\x-> x <> ".Template").tcmModule) tmods+ th = map ((\x-> x <> ".TH").tcmModule) tmods+ in -- unlines+ [summarymod]<>cmodstrs<>rawType<>ffi<>interface<>cast<>implementation<>template<>th --- | generate other modules in cabal file -genOtherModules :: [ClassModule] -> String -genOtherModules _cmods = "" +-- | generate other modules in cabal file+genOtherModules :: [ClassModule] -> [String]+genOtherModules _cmods = [""] +-- | generate additional package dependencies.+genPkgDeps :: [CabalName] -> [String]+genPkgDeps cs = [ "base > 4 && < 5"+ , "fficxx >= 0.5"+ , "fficxx-runtime >= 0.5"+ , "template-haskell"+ ]+ ++ map unCabalName cs ++ -- | cabalTemplate :: Text cabalTemplate =@@ -138,7 +161,7 @@ \ 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\+ \ Build-Depends: $pkgdeps\n\ \ Exposed-Modules:\n\ \$exposedModules\n\ \ Other-Modules:\n\@@ -146,54 +169,113 @@ \ extra-lib-dirs: $extralibdirs\n\ \ extra-libraries: stdc++ $extraLibraries\n\ \ Include-dirs: csrc $extraincludedirs\n\+ \ pkgconfig-depends: $pkgconfigDepends\n\ \ Install-includes:\n\ \$includeFiles\n\ \ C-sources:\n\ \$cppFiles\n" --- |-buildCabalFile :: (Cabal, CabalAttr)- -> String- -> PackageConfig- -> [String] -- ^ extra libs- -> FilePath- -> IO ()-buildCabalFile (cabal, cabalattr) summarymodule pkgconfig extralibs cabalfile = do+++-- TODO: remove all T.pack after we switch over to Text+genCabalInfo+ :: Cabal+ -> String+ -> PackageConfig+ -> [String] -- ^ extra libs+ -> GeneratedCabalInfo+genCabalInfo cabal summarymodule pkgconfig extralibs = let tih = pcfg_topLevelImportHeader pkgconfig classmodules = pcfg_classModules pkgconfig cih = pcfg_classImportHeaders pkgconfig tmods = pcfg_templateClassModules pkgconfig tcih = pcfg_templateClassImportHeaders pkgconfig acincs = pcfg_additional_c_incs pkgconfig- acsrcs = pcfg_additional_c_srcs pkgconfig - extrafiles = cabalattr_extrafiles cabalattr- 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", "")- , ("extraFiles", concatMap (\x -> cabalIndentation <> x <> "\n") extrafiles)- , ("csrcFiles", genCsrcFiles (tih,classmodules) acincs acsrcs)- , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) (cih,tcih) acincs)- , ("cppFiles", genCppFiles (tih,classmodules) acsrcs)- , ("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+ acsrcs = pcfg_additional_c_srcs pkgconfig+ extrafiles = cabal_extrafiles cabal+ in GeneratedCabalInfo {+ gci_pkgname = T.pack (unCabalName (cabal_pkgname cabal))+ , gci_version = T.pack (cabal_version cabal)+ , gci_synopsis = ""+ , gci_description = ""+ , gci_homepage = ""+ , gci_license = maybe "" T.pack (cabal_license cabal)+ , gci_licenseFile = maybe "" T.pack (cabal_licensefile cabal)+ , gci_author = ""+ , gci_maintainer = ""+ , gci_category = ""+ , gci_buildtype = "Simple"+ , gci_extraFiles = map T.pack extrafiles+ , gci_csrcFiles = map T.pack $ genCsrcFiles (tih,classmodules) acincs acsrcs+ , gci_sourcerepository = ""+ , gci_ccOptions = ["-std=c++14"]+ , gci_pkgdeps = map T.pack $ genPkgDeps (cabal_additional_pkgdeps cabal)+ , gci_exposedModules = map T.pack $ genExposedModules summarymodule (classmodules,tmods)+ , gci_otherModules = map T.pack $ genOtherModules classmodules+ , gci_extraLibDirs = map T.pack $ cabal_extralibdirs cabal+ , gci_extraLibraries = map T.pack extralibs+ , gci_extraIncludeDirs = map T.pack $ cabal_extraincludedirs cabal+ , gci_pkgconfigDepends = map T.pack $ cabal_pkg_config_depends cabal+ , gci_includeFiles = map T.pack $ genIncludeFiles (unCabalName (cabal_pkgname cabal)) (cih,tcih) acincs+ , gci_cppFiles = map T.pack $ genCppFiles (tih,classmodules) acsrcs+ } ++genCabalFile :: GeneratedCabalInfo -> Text+genCabalFile GeneratedCabalInfo {..} =+ TL.toStrict $+ substitute cabalTemplate $+ contextT [ ("licenseField" , "license: " <> gci_license)+ , ("licenseFileField", "license-file: " <> gci_licenseFile)+ , ("pkgname" , gci_pkgname)+ , ("version" , gci_version)+ , ("buildtype" , gci_buildtype)+ , ("synopsis" , gci_synopsis)+ , ("description" , gci_description)+ , ("homepage" , gci_homepage)+ , ("author" , gci_author)+ , ("maintainer" , gci_maintainer)+ , ("category" , gci_category)+ , ("sourcerepository", gci_sourcerepository)+ , ("ccOptions" , T.intercalate " " gci_ccOptions)+ , ("pkgdeps" , T.intercalate ", " gci_pkgdeps)+ , ("extraFiles" , unlinesWithIndent gci_extraFiles)+ , ("csrcFiles" , unlinesWithIndent gci_csrcFiles)+ , ("includeFiles" , unlinesWithIndent gci_includeFiles)+ , ("cppFiles" , unlinesWithIndent gci_cppFiles)+ , ("exposedModules" , unlinesWithIndent gci_exposedModules)+ , ("otherModules" , unlinesWithIndent gci_otherModules)+ , ("extralibdirs" , T.intercalate ", " gci_extraLibDirs)+ , ("extraincludedirs", T.intercalate ", " gci_extraIncludeDirs)+ , ("extraLibraries" , T.intercalate ", " gci_extraLibraries)+ , ("cabalIndentation", cabalIndentation)+ , ("pkgconfigDepends", T.intercalate ", " gci_pkgconfigDepends)+ ]+++-- |+buildCabalFile+ :: Cabal+ -> String+ -> PackageConfig+ -> [String] -- ^ Extra libs+ -> FilePath -- ^ Cabal file path+ -> IO ()+buildCabalFile cabal summarymodule pkgconfig extralibs cabalfile = do+ let+ cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs+ txt = genCabalFile cinfo+ TIO.writeFile cabalfile txt+++-- |+buildJSONFile+ :: Cabal+ -> String+ -> PackageConfig+ -> [String] -- ^ Extra libs+ -> FilePath -- ^ JSON file path+ -> IO ()+buildJSONFile cabal summarymodule pkgconfig extralibs jsonfile = do+ let cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs+ BL.writeFile jsonfile (encodePretty cinfo)
lib/FFICXX/Generate/Code/Cpp.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Cpp--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,17 +15,37 @@ module FFICXX.Generate.Code.Cpp where -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+import Data.Char+import Data.List (intercalate)+import Data.Monoid ((<>)) --+import FFICXX.Generate.Code.Primitive (accessorCFunSig+ ,argsToCallString+ ,argsToString+ ,argsToStringNoSelf+ ,castCpp2C+ ,castC2Cpp+ ,CFunSig(..)+ ,genericFuncArgs+ ,genericFuncRet+ ,rettypeToString+ ,tmplMemFuncArgToString+ ,tmplMemFuncRetTypeToString+ ,tmplAllArgsToCallString+ ,tmplAllArgsToString+ ,tmplRetTypeToString)+import FFICXX.Generate.Name (aliasedFuncName+ ,cppFuncName+ ,ffiClassName+ ,ffiTmplFuncName+ ,hsTemplateMemberFunctionName)+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Type.PackageInterface+import FFICXX.Generate.Util --+-- -- Class Declaration and Definition -- @@ -35,110 +55,144 @@ ---- "Class Type Declaration" Instances -genCppHeaderTmplType :: Class -> String -genCppHeaderTmplType c = let tmpl = "// Opaque type definition for $classname \n\+genCppHeaderMacroType :: Class -> String+genCppHeaderMacroType 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) ])+ in subst tmpl (context [ ("classname", ffiClassName c) ]) -genAllCppHeaderTmplType :: [Class] -> String-genAllCppHeaderTmplType = intercalateWith connRet2 (genCppHeaderTmplType) ----- "Class Declaration Virtual" Declaration +---- "Class Declaration Virtual" Declaration -genCppHeaderTmplVirtual :: Class -> String -genCppHeaderTmplVirtual aclass = +genCppHeaderMacroVirtual :: Class -> String+genCppHeaderMacroVirtual aclass = let tmpl = "#undef ${classname}_DECL_VIRT \n#define ${classname}_DECL_VIRT(Type) \\\n${funcdecl}" funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass- in subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) - , ("funcdecl" , funcDeclStr ) ]) - -genAllCppHeaderTmplVirtual :: [Class] -> String -genAllCppHeaderTmplVirtual = intercalateWith connRet2 genCppHeaderTmplVirtual+ in subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) )+ , ("funcdecl" , funcDeclStr ) ]) + ---- "Class Declaration Non-Virtual" Declaration -genCppHeaderTmplNonVirtual :: Class -> String-genCppHeaderTmplNonVirtual c = - let tmpl = "#undef ${classname}_DECL_NONVIRT \n#define ${classname}_DECL_NONVIRT(Type) \\\n$funcdecl" - declBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name c))+genCppHeaderMacroNonVirtual :: Class -> String+genCppHeaderMacroNonVirtual c =+ let tmpl = "#undef ${classname}_DECL_NONVIRT \n#define ${classname}_DECL_NONVIRT(Type) \\\n$funcdecl"+ declBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c)) , ("funcdecl" , funcDeclStr ) ])- funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc) + funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc) . class_funcs $ c- in declBodyStr + in declBodyStr -genAllCppHeaderTmplNonVirtual :: [Class] -> String -genAllCppHeaderTmplNonVirtual = intercalateWith connRet genCppHeaderTmplNonVirtual ----- "Class Declaration Virtual/NonVirtual" Instances+---- "Class Declaration Accessor" Declaration -genCppHeaderInstVirtual :: (Class,Class) -> String -genCppHeaderInstVirtual (p,c) = - let strc = map toUpper (class_name p) - in strc<>"_DECL_VIRT(" <> class_name c <> ");\n"+genCppHeaderMacroAccessor :: Class -> String+genCppHeaderMacroAccessor c =+ let tmpl = "#undef ${classname}_DECL_ACCESSOR\n#define ${classname}_DECL_ACCESSOR(Type)\\\n$funcdecl"+ declBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c))+ , ("funcdecl" , funcDeclStr ) ])+ funcDeclStr = accessorsToDecls (class_vars c)+ in declBodyStr -genCppHeaderInstNonVirtual :: Class -> String -genCppHeaderInstNonVirtual c = - let strx = map toUpper (class_name c) - in strx<>"_DECL_NONVIRT(" <> class_name c <> ");\n" -genAllCppHeaderInstNonVirtual :: [Class] -> String -genAllCppHeaderInstNonVirtual = - intercalateWith connRet genCppHeaderInstNonVirtual+---- "Class Declaration Virtual/NonVirtual/Accessor" Instances +genCppHeaderInstVirtual :: (Class,Class) -> String+genCppHeaderInstVirtual (p,c) =+ let strc = map toUpper (ffiClassName p)+ in strc<>"_DECL_VIRT(" <> ffiClassName c <> ");\n" +genCppHeaderInstNonVirtual :: Class -> String+genCppHeaderInstNonVirtual c =+ let strx = map toUpper (ffiClassName c)+ in strx<>"_DECL_NONVIRT(" <> ffiClassName c <> ");\n"+++genCppHeaderInstAccessor :: Class -> String+genCppHeaderInstAccessor c =+ let strx = map toUpper (ffiClassName c)+ in strx<>"_DECL_ACCESSOR(" <> ffiClassName c <> ");\n"++ ---- ---- Definition ---- ---- "Class Definition Virtual" Declaration -genCppDefTmplVirtual :: Class -> String -genCppDefTmplVirtual aclass = - 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 ) ]) +genCppDefMacroVirtual :: Class -> String+genCppDefMacroVirtual aclass =+ let tmpl = "#undef ${classname}_DEF_VIRT\n#define ${classname}_DEF_VIRT(Type)\\\n$funcdef"+ defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) )+ , ("funcdef" , funcDefStr ) ]) funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass- in defBodyStr - -genAllCppDefTmplVirtual :: [Class] -> String-genAllCppDefTmplVirtual = intercalateWith connRet2 genCppDefTmplVirtual+ in defBodyStr + ---- "Class Definition NonVirtual" Declaration -genCppDefTmplNonVirtual :: Class -> String -genCppDefTmplNonVirtual aclass = - 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) +genCppDefMacroNonVirtual :: Class -> String+genCppDefMacroNonVirtual aclass =+ let tmpl = "#undef ${classname}_DEF_NONVIRT\n#define ${classname}_DEF_NONVIRT(Type)\\\n$funcdef"+ defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) )+ , ("funcdef" , funcDefStr ) ])+ funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc) . class_funcs $ aclass- in defBodyStr - -genAllCppDefTmplNonVirtual :: [Class] -> String-genAllCppDefTmplNonVirtual = intercalateWith connRet2 genCppDefTmplNonVirtual+ in defBodyStr ----- "Class Definition Virtual/NonVirtual" Instances -genCppDefInstVirtual :: (Class,Class) -> String -genCppDefInstVirtual (p,c) = - let strc = map toUpper (class_name p) - in strc<>"_DEF_VIRT(" <> class_name c <> ")\n"+---- Define Macro to provide Accessor C-C++ shim code for a class +genCppDefMacroAccessor :: Class -> String+genCppDefMacroAccessor c =+ let tmpl = "#undef ${classname}_DEF_ACCESSOR\n#define ${classname}_DEF_ACCESSOR(Type)\\\n$funcdef"+ defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c))+ , ("funcdef" , funcDefStr ) ])+ funcDefStr = accessorsToDefs (class_vars c)+ in defBodyStr++---- Define Macro to provide TemplateMemberFunction C-C++ shim code for a class++genCppDefMacroTemplateMemberFunction :: Class -> TemplateMemberFunction -> String+genCppDefMacroTemplateMemberFunction c f = subst tmpl ctxt+ where+ tmpl = "#define ${macroname}(Type) \\\n\+ \ extern \"C\" { \\\n\+ \ $decl; \\\n\+ \ } \\\n\+ \ inline $defn \\\n\+ \ auto a_${macroname}_##Type = ${macroname}_##Type ;\n"+ ctxt = context+ [ ("macroname", hsTemplateMemberFunctionName c f)+ , ("decl" , tmplMemberFunToDecl c f)+ , ("defn" , tmplMemberFunToDef c f)+ ]+++---- Invoke Macro to define Virtual/NonVirtual method for a class++genCppDefInstVirtual :: (Class,Class) -> String+genCppDefInstVirtual (p,c) =+ let strc = map toUpper (ffiClassName p)+ in strc<>"_DEF_VIRT(" <> ffiClassName c <> ")\n"+ genCppDefInstNonVirtual :: Class -> String-genCppDefInstNonVirtual c = +genCppDefInstNonVirtual c = subst "${capitalclassname}_DEF_NONVIRT(${classname})"- (context [ ("capitalclassname", toUppers (class_name c))- , ("classname" , class_name c ) ]) + (context [ ("capitalclassname", toUppers (ffiClassName c))+ , ("classname" , ffiClassName c ) ]) -genAllCppDefInstNonVirtual :: [Class] -> String -genAllCppDefInstNonVirtual = intercalateWith connRet genCppDefInstNonVirtual+genCppDefInstAccessor :: Class -> String+genCppDefInstAccessor c =+ subst "${capitalclassname}_DEF_ACCESSOR(${classname})"+ (context [ ("capitalclassname", toUppers (ffiClassName c))+ , ("classname" , ffiClassName c ) ]) ----------------- -genAllCppHeaderInclude :: ClassImportHeader -> String -genAllCppHeaderInclude header = +genAllCppHeaderInclude :: ClassImportHeader -> String+genAllCppHeaderInclude header = intercalateWith connRet (\x->"#include \""<>x<>"\"") $ map unHdrName (cihIncludedHPkgHeadersInCPP header <> cihIncludedCPkgHeaders header)@@ -151,37 +205,37 @@ -- TOP LEVEL FUNCTIONS -- ------------------------- -genTopLevelFuncCppHeader :: TopLevelFunction -> String -genTopLevelFuncCppHeader TopLevelFunction {..} = - subst "$returntype $funcname ( $args );" - (context [ ("returntype", rettypeToString toplevelfunc_ret ) - , ("funcname" , "TopLevel_" +genTopLevelFuncCppHeader :: TopLevelFunction -> String+genTopLevelFuncCppHeader TopLevelFunction {..} =+ subst "$returntype $funcname ( $args );"+ (context [ ("returntype", rettypeToString toplevelfunc_ret )+ , ("funcname" , "TopLevel_" <> maybe toplevelfunc_name id toplevelfunc_alias) , ("args" , argsToStringNoSelf toplevelfunc_args ) ])-genTopLevelFuncCppHeader TopLevelVariable {..} = +genTopLevelFuncCppHeader TopLevelVariable {..} = subst "$returntype $funcname ( );"- (context [ ("returntype", rettypeToString toplevelvar_ret ) - , ("funcname" , "TopLevel_" - <> maybe toplevelvar_name id toplevelvar_alias) ]) + (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}" +genTopLevelFuncCppDefinition :: TopLevelFunction -> String+genTopLevelFuncCppDefinition TopLevelFunction {..} =+ let tmpl = "$returntype $funcname ( $args ) { \n $funcbody\n}" callstr = toplevelfunc_name <> "("- <> argsToCallString toplevelfunc_args + <> argsToCallString toplevelfunc_args <> ")" funcDefStr = returnCpp False (toplevelfunc_ret) callstr- in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret ) - , ("funcname" , "TopLevel_" + in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret )+ , ("funcname" , "TopLevel_" <> maybe toplevelfunc_name id toplevelfunc_alias)- , ("args" , argsToStringNoSelf toplevelfunc_args ) + , ("args" , argsToStringNoSelf toplevelfunc_args ) , ("funcbody" , funcDefStr ) ])-genTopLevelFuncCppDefinition TopLevelVariable {..} = - let tmpl = "$returntype $funcname ( ) { \n $funcbody\n}" +genTopLevelFuncCppDefinition TopLevelVariable {..} =+ 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_" + in subst tmpl (context [ ("returntype", rettypeToString toplevelvar_ret )+ , ("funcname" , "TopLevel_" <> maybe toplevelvar_name id toplevelvar_alias) , ("funcbody" , funcDefStr ) ]) @@ -189,7 +243,7 @@ genTmplFunCpp :: Bool -- ^ is for simple type? -> TemplateClass -> TemplateFunction- -> String + -> String genTmplFunCpp b t@TmplCls {..} f = subst tmpl ctxt where tmpl = "#define ${tname}_${fname}${suffix}(Type) \\\n\@@ -198,38 +252,239 @@ \ } \\\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 ) ]+ ctxt = context $+ (("suffix",if b then "_s" else ""):) $+ [ ("tname" , tclass_name )+ , ("fname" , ffiTmplFuncName f)+ , ("decl" , tmplFunToDecl b t f )+ , ("defn" , tmplFunToDef b t f ) ] genTmplClassCpp :: Bool -- ^ is for simple type -> TemplateClass -> [TemplateFunction]- -> String + -> 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 ) + , ("suffix" , suffix ) , ("macro" , macro ) ] tname = tclass_name- - macro1 TFun {..} = " " <> tname<> "_" <> tfun_name <> suffix <> "(Type) \\"- - macro1 TFunNew {..} = " " <> tname<> "_new(Type) \\"- macro1 TFunDelete = " " <> tname<> "_delete(Type) \\" + macro1 f@TFun {..} = " " <> tname<> "_" <> ffiTmplFuncName f <> suffix <> "(Type) \\"++ macro1 f@TFunNew {..} = " " <> tname<> "_" <> ffiTmplFuncName f <> "(Type) \\"+ macro1 TFunDelete = " " <> tname<> "_delete(Type) \\" macro = intercalateWith connRet macro1 fs- ++returnCpp :: Bool -- ^ for simple type+ -> Types+ -> String -- ^ call string+ -> String+returnCpp b ret callstr =+ case ret of+ Void -> callstr <> ";"+ SelfType -> "return to_nonconst<Type ## _t, Type>((Type *)"+ <> callstr <> ") ;"+ CT (CRef _) _ -> "return (&("<>callstr<>"));"+ CT _ _ -> "return "<>callstr<>";"+ CPT (CPTClass c') _ -> "return to_nonconst<"<>str<>"_t,"<>str+ <>">(("<>str<>"*)"<>callstr<>");"+ where str = ffiClassName c'+ CPT (CPTClassRef c') _ -> "return to_nonconst<"<>str<>"_t,"<>str+ <>">(&("<>callstr<>"));"+ where str = ffiClassName c'+ CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str+ <>">(new "<>str<>"("<>callstr<>"));"+ where str = ffiClassName c'+ CPT (CPTClassMove c') _ -> -- TODO: check whether this is working or not.+ "return std::move(to_nonconst<"<>str<>"_t,"<>str+ <>">(&("<>callstr<>")));"+ where str = ffiClassName c'+ TemplateApp (TemplateAppInfo _ _ cpptype) ->+ cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); "+ <> "return (static_cast<void*>(r));"+ TemplateAppRef (TemplateAppInfo _ _ cpptype) ->+ cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); "+ <> "return (static_cast<void*>(r));"+ TemplateAppMove (TemplateAppInfo _ _ cpptype) ->+ cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); "+ <> "return std::move(static_cast<void*>(r));"+ TemplateType _ -> error "returnCpp: TemplateType"+ TemplateParam _ ->+ if b then "return (" <> callstr <> ");"+ else "return to_nonconst<Type ## _t, Type>((Type *)&("+ <> callstr <> ")) ;"+ TemplateParamPointer _ ->+ if b then "return (" <> callstr <> ");"+ else "return to_nonconst<Type ## _t, Type>("+ <> callstr <> ") ;"++++-- Function Declaration and Definition++funcToDecl :: Class -> Function -> String+funcToDecl c func+ | isNewFunc func || isStaticFunc 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 subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func))+ , ("funcname", aliasedFuncName c func)+ , ("args", argsToString (genericFuncArgs func))+ ])++++funcsToDecls :: Class -> [Function] -> String+funcsToDecls c = intercalateWith connSemicolonBSlash (funcToDecl c)+++funcToDef :: Class -> Function -> String+funcToDef c func+ | isNewFunc func =+ let declstr = funcToDecl c func+ callstr = "(" <> argsToCallString (genericFuncArgs func) <> ")"+ returnstr = "Type * newp = new Type " <> callstr <> "; \\\nreturn to_nonconst<Type ## _t, Type >(newp);"+ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"]+ | isDeleteFunc func =+ let declstr = funcToDecl c func+ returnstr = "delete (to_nonconst<Type,Type ## _t>(p)) ; "+ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"]+ | isStaticFunc func =+ let declstr = funcToDecl c func+ callstr = cppFuncName c func <> "("+ <> argsToCallString (genericFuncArgs func)+ <> ")"+ returnstr = returnCpp False (genericFuncRet func) callstr+ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"]+ | otherwise =+ let declstr = funcToDecl c func+ callstr = "to_nonconst<Type,Type ## _t>(p)->"+ <> cppFuncName c func <> "("+ <> argsToCallString (genericFuncArgs func)+ <> ")"+ returnstr = returnCpp False (genericFuncRet func) callstr+ in intercalateWith connBSlash id [declstr, "{", returnstr, "}"]++++funcsToDefs :: Class -> [Function] -> String+funcsToDefs c = intercalateWith connBSlash (funcToDef c)+++tmplFunToDecl :: Bool -> TemplateClass -> TemplateFunction -> String+tmplFunToDecl b t@TmplCls {..} f@TFun {..} =+ subst "$ret ${tname}_${fname}_ ## Type ( $args )"+ (context [ ("tname", tclass_name)+ , ("fname", ffiTmplFuncName f)+ , ("args" , tmplAllArgsToString b Self t tfun_args)+ , ("ret" , tmplRetTypeToString b tfun_ret) ])+tmplFunToDecl b t@TmplCls {..} f@TFunNew {..} =+ subst "$ret ${tname}_${fname}_ ## Type ( $args )"+ (context [ ("tname", tclass_name)+ , ("fname", ffiTmplFuncName f)+ , ("args" , tmplAllArgsToString b NoSelf t tfun_new_args)+ , ("ret" , tmplRetTypeToString b (TemplateType t)) ])+tmplFunToDecl b t@TmplCls {..} TFunDelete =+ subst "$ret ${tname}_delete_ ## Type ( $args )"+ (context [ ("tname", tclass_name )+ , ("args" , tmplAllArgsToString b 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 {..} -> "(static_cast<" <> tclass_oname <> "<Type>*>(p))->"+ <> tfun_oname <> "("+ <> tmplAllArgsToCallString b tfun_args+ <> ")"+ TFunNew {..} -> "new " <> tclass_oname <> "<Type>("+ <> tmplAllArgsToCallString b tfun_new_args+ <> ")"+ TFunDelete -> "delete (static_cast<" <> tclass_oname <> "<Type>*>(p))"+ returnstr =+ case f of+ TFunNew {..} -> "return static_cast<void*>("<>callstr<>");"+ TFunDelete -> callstr <> ";"+ TFun {..} -> returnCpp b (tfun_ret) callstr+++-- Accessor Declaration and Definition++accessorToDecl :: Variable -> Accessor -> String+accessorToDecl v a =+ let tmpl = "$returntype Type ## _$funcname ( $args )"+ csig = accessorCFunSig (var_type v) a+ in subst tmpl (context [ ("returntype", rettypeToString (cRetType csig))+ , ("funcname" , var_name v <> "_" <> case a of Getter -> "get"; Setter -> "set")+ , ("args" , argsToString (cArgTypes csig))+ ])++accessorsToDecls :: [Variable] -> String+accessorsToDecls vs =+ let dcls = concatMap (\v -> [accessorToDecl v Getter,accessorToDecl v Setter]) vs+ in intercalate "; \\\n" dcls+++accessorToDef :: Variable -> Accessor -> String+accessorToDef v a =+ let declstr = accessorToDecl v a+ varexp = "to_nonconst<Type,Type ## _t>(p)->" <> var_name v+ body Getter = "return (" <> castCpp2C (var_type v) varexp <> ");"+ body Setter = varexp+ <> " = "+ <> castC2Cpp (var_type v) "x" -- TODO: somehow clean up this hard-coded "x".+ <> ";"+ in intercalate "\\\n" [declstr, "{", body a, "}"]+++accessorsToDefs :: [Variable] -> String+accessorsToDefs vs =+ let defs = concatMap (\v -> [accessorToDef v Getter,accessorToDef v Setter]) vs+ in intercalate "; \\\n" defs++++-- Template Member Function Declaration and Definition++-- TODO: Handle simple type+tmplMemberFunToDecl :: Class -> TemplateMemberFunction -> String+tmplMemberFunToDecl c f =+ subst "$ret ${macroname}_##Type ( $args )"+ (context [ ("macroname", hsTemplateMemberFunctionName c f)+ , ("args" , intercalateWith conncomma (tmplMemFuncArgToString c) ((SelfType,"p"):tmf_args f))+ , ("ret" , tmplMemFuncRetTypeToString c (tmf_ret f))+ ])+++-- TODO: Handle simple type+tmplMemberFunToDef :: Class -> TemplateMemberFunction -> String+tmplMemberFunToDef c f =+ intercalateWith connBSlash id [ declstr+ , " {"+ , " " <> returnstr+ , " }"+ ]+ where+ declstr = tmplMemberFunToDecl c f+ callstr = "(to_nonconst<" <> ffiClassName c <> "," <> ffiClassName c <> "_t" <> ">(p))"+ <> "->"+ <> tmf_name f+ <> "<Type>"+ <> "(" <> tmplAllArgsToCallString False (tmf_args f) <> ")"+ returnstr = returnCpp False (tmf_ret f) callstr
− lib/FFICXX/Generate/Code/Dependency.hs
@@ -1,266 +0,0 @@-{-# LANGUAGE RecordWildCards #-}---------------------------------------------------------------------------------- |--- Module : FFICXX.Generate.Code.Dependency--- Copyright : (c) 2011-2017 Ian-Woo Kim------ License : BSD3--- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>--- Stability : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Code.Dependency where------- fficxx generates one module per one C++ class, and C++ class depends on other classes,--- so we need to import other modules corresponding to C++ classes in the dependency list.--- Calculating the import list from dependency graph is what this module does.---- Previously, we have only `Class` type, but added `TemplateClass` recently. Therefore--- we have to calculate dependency graph for both types of classes. So we needed to change--- `Class` to `Either TemplateClass Class` in many of routines that calculates module import--- list.---- `Dep4Func` contains a list of classes (both ordinary and template types) that is needed--- for the definition of a member function.--- The goal of `extractClassDep...` functions are to extract Dep4Func, and from the definition--- of a class or a template class, we get a list of `Dep4Func`s and then we deduplicate the--- dependency class list and finally get the import list for the module corresponding to--- a given class. --- --import Data.Either ( rights )-import Data.Function ( on )-import qualified Data.HashMap.Strict as HM-import Data.List -import Data.Maybe-import Data.Monoid ( (<>) )-import System.FilePath ----import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface----import Debug.Trace----- utility functions--getclassname = either tclass_name class_name--getcabal = either tclass_cabal class_cabal--getparents = either (const []) (map Right . class_parents) --getmodulebase = either getTClassModuleBase getClassModuleBase---- |-extractClassFromType :: Types -> Maybe (Either TemplateClass Class)-extractClassFromType Void = Nothing-extractClassFromType SelfType = Nothing-extractClassFromType (CT _ _) = Nothing-extractClassFromType (CPT (CPTClass c) _) = Just (Right c)-extractClassFromType (CPT (CPTClassRef c) _) = Just (Right c)-extractClassFromType (CPT (CPTClassCopy c) _) = Just (Right c)-extractClassFromType (TemplateApp t _ _) = Just (Left t)-extractClassFromType (TemplateAppRef t _ _) = Just (Left t)-extractClassFromType (TemplateType t) = Just (Left t)-extractClassFromType (TemplateParam _) = Nothing----- | class dependency for a given function -data Dep4Func = Dep4Func { returnDependency :: Maybe (Either TemplateClass Class)- , argumentDependency :: [(Either TemplateClass Class)] }----- | -extractClassDep :: Function -> Dep4Func -extractClassDep (Constructor args _) = Dep4Func Nothing (catMaybes (map (extractClassFromType.fst) args))-extractClassDep (Virtual ret _ args _) = - Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)-extractClassDep (NonVirtual ret _ args _) =- Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)-extractClassDep (Static ret _ args _) = - Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)-extractClassDep (Destructor _) = - Dep4Func Nothing [] ---extractClassDepForTmplFun :: TemplateFunction -> Dep4Func -extractClassDepForTmplFun (TFun ret _ _ args _) = - Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)-extractClassDepForTmplFun (TFunNew args) =- Dep4Func Nothing (mapMaybe (extractClassFromType.fst) args)-extractClassDepForTmplFun TFunDelete = Dep4Func Nothing [] ---extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func -extractClassDepForTopLevelFunction f = - Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)- where ret = case f of - TopLevelFunction {..} -> toplevelfunc_ret- TopLevelVariable {..} -> toplevelvar_ret- args = case f of- TopLevelFunction {..} -> toplevelfunc_args- TopLevelVariable {..} -> [] ----- | -mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepRaw x@(Right c)- = (nub . filter (/= x) . mapMaybe (returnDependency.extractClassDep) . class_funcs) c-mkModuleDepRaw x@(Left t)- = (nub . filter (/= x) . mapMaybe (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t----- | -mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepHighNonSource y@(Right c) = - let fs = class_funcs c - pkgname = (cabal_pkgname . class_cabal) c- extclasses = (filter (\x-> x /= y && ((/= pkgname) . cabal_pkgname . getcabal) x) . concatMap (argumentDependency.extractClassDep)) fs- parents = map Right (class_parents c)- in nub (parents <> extclasses) -mkModuleDepHighNonSource y@(Left t) = - let fs = tclass_funcs t - pkgname = (cabal_pkgname . tclass_cabal) t - extclasses = (filter (\x-> x /= y && ((/= pkgname) . cabal_pkgname . getcabal) x) . concatMap (argumentDependency.extractClassDepForTmplFun)) fs- -- parents = class_parents c - in nub extclasses----- | -mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepHighSource y@(Right c) = - let fs = class_funcs c - pkgname = (cabal_pkgname . class_cabal) c - in nub . filter (\x-> x /= y && not (x `elem` getparents y) && (((== pkgname) . cabal_pkgname . getcabal) x)) . concatMap (argumentDependency.extractClassDep) $ fs-mkModuleDepHighSource y@(Left t) = - let fs = tclass_funcs t- pkgname = (cabal_pkgname . tclass_cabal) t- in nub . filter (\x-> x /= y && not (x `elem` getparents y) && (((== pkgname) . cabal_pkgname . getcabal) x)) . concatMap (argumentDependency.extractClassDepForTmplFun) $ fs---- | -mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepCpp y@(Right c) = - let fs = class_funcs c - in nub . filter (/= y) $ - mapMaybe (returnDependency.extractClassDep) fs - <> concatMap (argumentDependency.extractClassDep) fs- <> getparents y-mkModuleDepCpp y@(Left t) = - let fs = tclass_funcs t- in nub . filter (/= y) $ - mapMaybe (returnDependency.extractClassDepForTmplFun) fs - <> concatMap (argumentDependency.extractClassDepForTmplFun) fs- <> getparents y---- | -mkModuleDepFFI4One :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepFFI4One (Right c) = - let fs = class_funcs c - in mapMaybe (returnDependency.extractClassDep) fs <> concatMap (argumentDependency.extractClassDep) fs -mkModuleDepFFI4One (Left t) = - let fs = tclass_funcs t - in mapMaybe (returnDependency.extractClassDepForTmplFun) fs <>- concatMap (argumentDependency.extractClassDepForTmplFun) fs ----- | -mkModuleDepFFI :: Either TemplateClass Class -> [Either TemplateClass Class] -mkModuleDepFFI y@(Right c) = - let ps = map Right (class_allparents c)- alldeps' = (concatMap mkModuleDepFFI4One ps) <> mkModuleDepFFI4One y- in nub (filter (/= y) alldeps')-mkModuleDepFFI y@(Left t) = [] -- -mkClassModule :: (Class->([Namespace],[HeaderName]))- -> [(String,[String])]- -> Class - -> ClassModule -mkClassModule mkincheaders extra c =- ClassModule (getClassModuleBase c) [c] (map (mkCIH mkincheaders) [c]) highs_nonsource- raws highs_source ffis extraimports-- where highs_nonsource = (map getmodulebase . mkModuleDepHighNonSource) (Right c)- raws = (map getmodulebase . mkModuleDepRaw) (Right c)- highs_source = (map getmodulebase . mkModuleDepHighSource) (Right c)- ffis = (map getmodulebase . mkModuleDepFFI) (Right 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)---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])])- -> [AddCInc]- -> [AddCSrc]- -> PackageConfig-mkPackageConfig (pkgname,mkNS_IncHdrs) (cs,fs,ts,extra) acincs acsrcs = - 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` getclassname) (tl_cs1 <> tl_cs2)- tl_cihs = catMaybes $ - foldr (\c acc-> (find (\x -> (class_name . cihClass) x == getclassname c) cihs):acc) [] tl_cs - -- - tih = TopLevelImportHeader (pkgname <> "TopLevel") tl_cihs fs- tcms = map mkTCM ts- tcihs = concatMap tcmTCIH tcms- in PkgConfig ms cihs tih tcms tcihs acincs acsrcs---mkHSBOOTCandidateList :: [ClassModule] -> [String]-mkHSBOOTCandidateList ms = nub (concatMap cmImportedModulesHighSource ms)---- | -mkPkgHeaderFileName ::Class -> HeaderName-mkPkgHeaderFileName c = - HdrName ((cabal_cheaderprefix.class_cabal) c <> class_name c <.> "h")---- | -mkPkgCppFileName ::Class -> String -mkPkgCppFileName c = - (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 . getcabal) . mkModuleDepCpp) (Right c)- extheaders = nub . map ((<>"Type.h") . cabal_pkgname . getcabal) $ extclasses - in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders-- ---- | -mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]-mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right----- | -mkCIH :: (Class->([Namespace],[HeaderName])) -- ^ (mk namespace and include headers) - -> Class - -> ClassImportHeader-mkCIH mkNSandIncHdrs c = ClassImportHeader c - (mkPkgHeaderFileName c) - ((fst . mkNSandIncHdrs) c)- (mkPkgCppFileName c) - (mkPkgIncludeHeadersInH c) - (mkPkgIncludeHeadersInCPP c)- ((snd . mkNSandIncHdrs) c)
+ lib/FFICXX/Generate/Code/HsCast.hs view
@@ -0,0 +1,37 @@+module FFICXX.Generate.Code.HsCast where++import Language.Haskell.Exts.Build (app)+import Language.Haskell.Exts.Syntax (Decl(..),InstDecl(..))+--+import FFICXX.Generate.Name (hsClassName,typeclassName)+import FFICXX.Generate.Type.Class (Class(..),isAbstractClass)+import FFICXX.Generate.Util.HaskellSrcExts (classA+ ,cxEmpty,cxTuple,insDecl+ ,mkBind1,mkInstance,mkPVar,mkTVar,mkVar+ ,tyapp,tycon,tyPtr+ ,unqual)+-----++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+ a = mkTVar "a"+ ctxt = cxTuple [ classA (unqual iname) [a], classA (unqual "FPtr") [a] ]+ in Just (mkInstance ctxt "Castable" [a,tyapp tyPtr (tycon rname)] castBody)+ | otherwise = Nothing++genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())+genHsFrontInstCastableSelf c+ | (not.isAbstractClass) c =+ let (cname,rname) = hsClassName c+ in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)+ | otherwise = Nothing+
lib/FFICXX/Generate/Code/HsFFI.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFFI--- Copyright : (c) 2011-2017 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,41 +15,81 @@ module FFICXX.Generate.Code.HsFFI where -import Data.Maybe ( fromMaybe, mapMaybe )-import Data.Monoid ( (<>) )-import Language.Haskell.Exts.Syntax ( Decl(..) )-import System.FilePath ((<.>))--- -import FFICXX.Generate.Util-import FFICXX.Generate.Util.HaskellSrcExts-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface+import Data.Maybe (fromMaybe,mapMaybe)+import Data.Monoid ((<>))+import Language.Haskell.Exts.Syntax (Decl(..),ImportDecl(..))+import System.FilePath ((<.>))+--+import FFICXX.Generate.Code.Primitive (CFunSig(..)+ ,accessorCFunSig+ ,genericFuncArgs+ ,genericFuncRet+ ,hsFFIFuncTyp)+import FFICXX.Generate.Dependency (class_allparents+ ,getClassModuleBase+ ,getTClassModuleBase)+import FFICXX.Generate.Name (aliasedFuncName+ ,ffiClassName+ ,hscAccessorName+ ,hscFuncName)+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Type.PackageInterface+import FFICXX.Generate.Util+import FFICXX.Generate.Util.HaskellSrcExts + genHsFFI :: ClassImportHeader -> [Decl ()] genHsFFI header = let c = cihClass header+ -- TODO: This C header information should not be necessary according to up-to-date+ -- version of Haskell FFI. h = cihSelfHeader header- allfns = concatMap (virtualFuncs . class_funcs) - (class_allparents c)- <> (class_funcs c) - in mapMaybe (hsFFIClassFunc h c) allfns+ -- NOTE: We need to generate FFI both for member functions at the current class level+ -- and parent level. For example, consider a class A with method foo, which a+ -- subclass of B with method bar. Then, A::foo (c_a_foo) and A::bar (c_a_bar)+ -- are made into a FFI function.+ allfns = concatMap (virtualFuncs . class_funcs)+ (class_allparents c)+ <> (class_funcs c) ---------+ in mapMaybe (hsFFIClassFunc h c) allfns+ <> concatMap+ (\v -> [hsFFIAccessor c v Getter, hsFFIAccessor c v Setter])+ (class_vars c) hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ()) hsFFIClassFunc headerfilename c f =- if isAbstractClass c + if isAbstractClass c then Nothing else let hfile = unHdrName headerfilename- cname = class_name c <> "_" <> aliasedFuncName c f+ -- TODO: Make this a separate function+ cname = ffiClassName c <> "_" <> aliasedFuncName c f+ csig = CFunSig (genericFuncArgs f) (genericFuncRet 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)+ then hsFFIFuncTyp (Just (NoSelf,c)) csig+ else hsFFIFuncTyp (Just (Self,c) ) csig in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ)- +++hsFFIAccessor ::Class -> Variable -> Accessor -> Decl ()+hsFFIAccessor c v a =+ let -- TODO: make this a separate function+ cname = ffiClassName c <> "_" <> var_name v <> "_" <> (case a of Getter -> "get"; Setter -> "set")+ typ = hsFFIFuncTyp (Just (Self,c)) (accessorCFunSig (var_type v) a)+ in mkForImpCcall cname (hscAccessorName c v a) typ+++-- import for FFI++genImportInFFI :: ClassModule -> [ImportDecl ()]+genImportInFFI = map mkMod . cmImportedModulesForFFI+ where mkMod (Left t) = mkImport (getTClassModuleBase t <.> "Template")+ mkMod (Right c) = mkImport (getClassModuleBase c <.> "RawType")++ ------------------------------- for top level function -- +-- for top level function -- ---------------------------- genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl ()@@ -59,6 +99,6 @@ TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) hfilename = tihHeaderFileName header <.> "h"+ -- TODO: This must be exposed as a top-level function cfname = "c_" <> toLowers fname- typ =hsFFIFuncTyp Nothing (args,ret)-+ typ =hsFFIFuncTyp Nothing (CFunSig args ret)
lib/FFICXX/Generate/Code/HsFrontEnd.hs view
@@ -1,11 +1,12 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecordWildCards #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFrontEnd--- Copyright : (c) 2011-2017 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -16,83 +17,74 @@ module FFICXX.Generate.Code.HsFrontEnd where -import Control.Monad.State-import Control.Monad.Reader-import Data.List-import Data.Monoid ( (<>) )-import Language.Haskell.Exts.Build ( app, binds, doE, letE, letStmt- , name, pApp- , qualStmt, strE, tuple- )-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.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)- in unlines commented_lines - | otherwise = str --mkPostComment :: String -> String-mkPostComment str - | (not.null) str = - let str_lines = lines str - commented_lines = - ("-- ^ "<>head str_lines) : map (\x->"-- "<>x) (tail str_lines)- in unlines commented_lines - | otherwise = str +import Control.Monad.Reader+import Data.Either (lefts,rights)+import Data.List+import Data.Monoid ((<>))+import Language.Haskell.Exts.Build (app,letE,name,pApp)+import Language.Haskell.Exts.Syntax (Decl(..),ExportSpec(..),ImportDecl(..))+import System.FilePath ((<.>))+--+import FFICXX.Generate.Code.Primitive (CFunSig(..),HsFunSig(..)+ ,accessorSignature+ ,classConstraints+ ,convertCpp2HS+ ,extractArgRetTypes+ ,functionSignature+ ,hsFuncXformer+ )+import FFICXX.Generate.Name (accessorName+ ,aliasedFuncName+ ,constructorName+ ,hsClassName+ ,hscAccessorName+ ,hscFuncName+ ,hsFuncName+ ,hsFrontNameForTopLevelFunction+ ,typeclassName)+import FFICXX.Generate.Dependency (class_allparents+ ,extractClassDepForTopLevelFunction+ ,getClassModuleBase,getTClassModuleBase+ ,argumentDependency,returnDependency+ )+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Annotate+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Util+import FFICXX.Generate.Util.HaskellSrcExts genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ()) genHsFrontDecl c = do+ -- TODO: revive annotation -- for the time being, let's ignore annotation.- -- amap <- ask - -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap + -- 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 + body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c return cdecl ------------------- genHsFrontInst :: Class -> Class -> [Decl ()]-genHsFrontInst parent child - | (not.isAbstractClass) child = +genHsFrontInst parent child+ | (not.isAbstractClass) child = let idecl = mkInstance cxEmpty (typeclassName parent) [convertCpp2HS (Just child) SelfType] body- defn f = mkBind1 (hsFuncName child f) [] rhs Nothing + 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 = []- - ++ --------------------- -genHsFrontInstNew :: Class -- ^ only concrete class +genHsFrontInstNew :: Class -- ^ only concrete class -> Reader AnnotateMap [Decl ()]-genHsFrontInstNew c = do +genHsFrontInstNew c = do -- amap <- ask let fs = filter isNewFunc (class_funcs c) return . flip concatMap fs $ \f ->@@ -105,7 +97,7 @@ genHsFrontInstNonVirtual :: Class -> [Decl ()] genHsFrontInstNonVirtual c =- flip concatMap nonvirtualFuncs $ \f -> + 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)@@ -120,28 +112,16 @@ ----- -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)- ]+genHsFrontInstVariables :: Class -> [Decl ()]+genHsFrontInstVariables c =+ flip concatMap (class_vars c) $ \v ->+ let rhs accessor =+ app (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1"))+ (mkVar (hscAccessorName c v accessor))+ in mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing+ <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing -genHsFrontInstCastable :: Class -> Maybe (Decl ())-genHsFrontInstCastable c - | (not.isAbstractClass) c = - let iname = typeclassName c- (_,rname) = hsClassName c- a = mkTVar "a"- ctxt = cxTuple [ classA (unqual iname) [a], classA (unqual "FPtr") [a] ]- in Just (mkInstance ctxt "Castable" [a,tyapp tyPtr (tycon rname)] castBody)- | otherwise = Nothing -genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())-genHsFrontInstCastableSelf c - | (not.isAbstractClass) c = - let (cname,rname) = hsClassName c- in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)- | otherwise = Nothing --------------------------@@ -155,7 +135,7 @@ , insDecl (mkBind1 "get_fptr" [pApp (name highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing) , insDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing) ]- + ] where (highname,rawname) = hsClassName c hightype = tycon highname@@ -163,7 +143,7 @@ mderiv = Just (mkDeriving [i_eq,i_ord,i_show]) where i_eq = irule Nothing Nothing (ihcon (unqual "Eq")) i_ord = irule Nothing Nothing (ihcon (unqual "Ord"))- i_show = irule Nothing Nothing (ihcon (unqual "Show")) + i_show = irule Nothing Nothing (ihcon (unqual "Show")) ------------@@ -204,7 +184,7 @@ (tyfun hightype a_tvar) rhs = letE [ 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") @@ -212,58 +192,67 @@ -- Top Level Function -- ------------------------ + genTopLevelFuncDef :: TopLevelFunction -> [Decl ()]-genTopLevelFuncDef f@TopLevelFunction {..} = +genTopLevelFuncDef f@TopLevelFunction {..} = let fname = hsFrontNameForTopLevelFunction f- (typs,assts) = extractArgRetTypes Nothing False (toplevelfunc_args,toplevelfunc_ret)+ HsFunSig typs assts =+ extractArgRetTypes+ Nothing+ False+ (CFunSig toplevelfunc_args toplevelfunc_ret) sig = tyForall Nothing (Just (cxTuple assts)) (foldr1 tyfun typs) xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull"- cfname = "c_" <> toLowers fname + cfname = "c_" <> toLowers fname rhs = app (mkVar xformerstr) (mkVar cfname)- - in mkFun fname sig [] rhs Nothing -genTopLevelFuncDef v@TopLevelVariable {..} = ++ in mkFun fname sig [] rhs Nothing+genTopLevelFuncDef v@TopLevelVariable {..} = let fname = hsFrontNameForTopLevelFunction v- cfname = "c_" <> toLowers fname - rtyp = (tycon . ctypToHsTyp Nothing) toplevelvar_ret+ cfname = "c_" <> toLowers fname+ rtyp = convertCpp2HS Nothing toplevelvar_ret sig = tyapp (tycon "IO") rtyp rhs = app (mkVar "xformnull") (mkVar cfname)- - in mkFun fname sig [] rhs Nothing + in mkFun fname sig [] rhs Nothing + ------------ -- Export -- ------------ genExport :: Class -> [ExportSpec ()] genExport c =- let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) + let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) then eabs nonamespace (unqual n) else ethingall (unqual n)- in if isAbstractClass c + in if isAbstractClass 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 + <> genExportConstructorAndNonvirtual c+ <> genExportStatic c --- | constructor and non-virtual function +-- | constructor and non-virtual function genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()] genExportConstructorAndNonvirtual c = map (evar . unqual) fns where fs = class_funcs c- fns = map (aliasedFuncName c) (constructorFuncs fs + fns = map (aliasedFuncName c) (constructorFuncs fs <> nonVirtualNotNewFuncs fs) --- | staic function export list +-- | staic function export list genExportStatic :: Class -> [ExportSpec ()] genExportStatic c = map (evar . unqual) fns where fs = class_funcs c- fns = map (aliasedFuncName c) (staticFuncs fs) + fns = map (aliasedFuncName c) (staticFuncs fs) +------------+-- Import --+------------+ genExtraImport :: ClassModule -> [ImportDecl ()] genExtraImport cm = map mkImport (cmExtraImport cm) @@ -271,127 +260,76 @@ 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 -> [ImportDecl ()]-genImportInInterface m = +genImportInInterface m = let modlstraw = cmImportedModulesRaw m- modlstparent = cmImportedModulesHighNonSource m + modlstparent = cmImportedModulesHighNonSource m modlsthigh = cmImportedModulesHighSource m in [mkImport (cmModule m <.> "RawType")]- <> map (\x -> mkImport (x<.>"RawType")) modlstraw- <> map (\x -> mkImport (x<.>"Interface")) modlstparent - <> map (\x -> mkImportSrc (x<.>"Interface")) modlsthigh+ <> flip map modlstraw+ (\case+ Left t -> mkImport (getTClassModuleBase t <.> "Template")+ Right c -> mkImport (getClassModuleBase c <.>"RawType")+ )+ <> flip map modlstparent+ (\case+ Left t -> mkImport (getTClassModuleBase t <.> "Template")+ Right c -> mkImport (getClassModuleBase c <.>"Interface")+ )+ <> flip map modlsthigh+ (\case+ Left t -> -- TODO: *.Template in the same package needs to have hs-boot.+ -- Currently, we do not have it yet.+ mkImport (getTClassModuleBase t <.> "Template")+ Right c -> mkImportSrc (getClassModuleBase c<.>"Interface")+ ) -- | genImportInCast :: ClassModule -> [ImportDecl ()] genImportInCast m = [ mkImport (cmModule m <.> "RawType") , mkImport (cmModule m <.> "Interface") ] --- | +-- | genImportInImplementation :: ClassModule -> [ImportDecl ()]-genImportInImplementation m = +genImportInImplementation m = let modlstraw' = cmImportedModulesForFFI m- modlsthigh = nub $ map getClassModuleBase $ concatMap class_allparents (cmClass m)- modlstraw = filter (not.(flip elem modlsthigh)) modlstraw' + modlsthigh = nub $ map Right $ concatMap class_allparents (cmClass m)+ modlstraw = filter (not.(flip elem modlsthigh)) modlstraw' 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-- -genTmplInterface :: TemplateClass -> [Decl ()]-genTmplInterface t =- [ mkData rname [mkTBind tp] [] Nothing- , mkNewtype hname [mkTBind tp]- [ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing- , mkClass cxEmpty (typeclassNameT t) [mkTBind tp] methods- , mkInstance cxEmpty "FPtr" [ hightype ] fptrbody- , mkInstance cxEmpty "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 (tyapp (tycon "Raw") hightype) rawtype- , insDecl (mkBind1 "get_fptr" [pApp (name 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 bstmts)- 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 = strE (prefix<>"_"<>nc<>"_")- lam = lambda [p "n"] ( lit `app` v "<>" `app` v "n") - rhs = app (v "mkTFunc") (tuple [v "nty", v "ncty", lam, v "tyf"])- sig' = functionSignatureTT t f- bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]- (letE [ pbind (p tp) (v "return" `app` (con "ConT" `app` v "n")) Nothing ]- (bracketExp (typeBracket sig')))- Nothing - ]+ <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c<.>y)) ["RawType","Cast","Interface"]) modlstraw+ <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c<.>y)) ["RawType","Cast","Interface"]) modlsthigh -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- sig = tycon "Name" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tylist (tycon "Dec"))))-- nfs = zip ([1..] :: [Int]) fs- rhs = doE (map genstmt nfs <> [letStmt (lststmt nfs), qualStmt retstmt])+-- | generate import list for a given top-level function+-- currently this may generate duplicate import list.+-- TODO: eliminate duplicated imports.+genImportForTopLevelFunction :: TopLevelFunction -> [ImportDecl ()]+genImportForTopLevelFunction f =+ let dep4func = extractClassDepForTopLevelFunction f+ ecs = returnDependency dep4func ++ argumentDependency dep4func+ cmods = nub $ map getClassModuleBase $ rights ecs+ tmods = nub $ map getTClassModuleBase $ lefts ecs+ in concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) cmods+ <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["Template"]) tmods - genstmt (n,TFun {..}) = generator (p ("f"<>show n))- (v "mkMember" `app` strE tfun_name- `app` v ("t_" <> tfun_name)- `app` v "n"- `app` v "ctyp"- )- genstmt (n,TFunNew {..}) = generator (p ("f"<>show n)) - (v "mkNew" `app` strE ("new" <> tname)- `app` v ("t_new" <> tname)- `app` v "n"- `app` v "ctyp"- )- genstmt (n,TFunDelete) = generator (p ("f"<>show n)) - (v "mkDelete" `app` strE ("delete"<>tname)- `app` v ("t_delete" <> tname)- `app` v "n"- `app` v "ctyp"- ) - lststmt xs = [ pbind (p "lst") (list (map (v . (\n->"f"<>show n) . fst) xs)) Nothing ]- retstmt = v "return"- `app` list [ v "mkInstance"- `app` list []- `app` (con "AppT"- `app` (v "con" `app` strE (typeclassNameT t))- `app` (con "ConT" `app` (v "n"))- )- `app` (v "lst")- ] +-- | generate import list for top level module+genImportInTopLevel ::+ String+ -> ([ClassModule],[TemplateClassModule])+ -> TopLevelImportHeader+ -> [ImportDecl ()]+genImportInTopLevel modname (mods,tmods) tih =+ let tfns = tihFuncs tih+ in map (mkImport . cmModule) mods+ ++ if null tfns+ then []+ else map mkImport [ "Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast" ]+ ++ map (\c -> mkImport (modname <.> (fst.hsClassName.cihClass) c <.> "RawType")) (tihClassDep tih)+ ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods+ ++ concatMap genImportForTopLevelFunction tfns
+ lib/FFICXX/Generate/Code/HsTemplate.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE RecordWildCards #-}+module FFICXX.Generate.Code.HsTemplate where++import Data.Monoid ((<>))+import Language.Haskell.Exts.Build (app,binds,doE,letE,letStmt,name,pApp+ ,qualStmt,strE,tuple)+import Language.Haskell.Exts.Syntax (Decl(..))+--+import FFICXX.Generate.Code.Primitive (functionSignatureT+ ,functionSignatureTT+ ,functionSignatureTMF)+import FFICXX.Generate.Code.HsCast (castBody)+import FFICXX.Generate.Name (ffiTmplFuncName+ ,hsTemplateClassName+ ,hsTemplateMemberFunctionName+ ,hsTemplateMemberFunctionNameTH+ ,hsTmplFuncName+ ,hsTmplFuncNameTH+ ,typeclassNameT)+import FFICXX.Generate.Type.Class (Class(..)+ ,TemplateClass(..)+ ,TemplateFunction(..)+ ,TemplateMemberFunction(..))+import FFICXX.Generate.Util.HaskellSrcExts (bracketExp+ ,con,conDecl,cxEmpty+ ,generator+ ,clsDecl,insDecl,insType+ ,lambda,list+ ,mkBind1,mkTBind,mkData,mkNewtype+ ,mkFun,mkFunSig,mkClass,mkInstance+ ,mkPVar,mkTVar,mkVar+ ,pbind,qualConDecl+ ,tyapp,tycon,tyfun,tylist,tyPtr+ ,typeBracket)++++------------------------------+-- Template member function --+------------------------------++genTemplateMemberFunctions :: Class -> [Decl ()]+genTemplateMemberFunctions c =+ concatMap (\f -> genTMFExp c f <> genTMFInstance c f) (class_tmpl_funcs c)+++genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()]+genTMFExp c f = mkFun nh sig [p "typ", p "suffix"] rhs (Just bstmts)+ where nh = hsTemplateMemberFunctionNameTH c f+ sig = tycon "Type" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tycon "Exp")))+ v = mkVar+ p = mkPVar+ tp = tmf_param f+ lit' = strE (hsTemplateMemberFunctionName c f <> "_")+ lam = lambda [p "n"] ( lit' `app` v "<>" `app` v "n")+ rhs = app (v "mkTFunc") (tuple [v "typ", v "suffix", lam, v "tyf"])+ sig' = functionSignatureTMF c f+ bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]+ (letE [ pbind (p tp) (v "pure" `app` (v "typ")) Nothing ]+ (bracketExp (typeBracket sig')))+ Nothing+ ]+++genTMFInstance :: Class -> TemplateMemberFunction -> [Decl ()]+genTMFInstance c f = mkFun fname sig [p "qtyp", p "suffix"] rhs Nothing+ where fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f+ p = mkPVar+ v = mkVar+ sig = (tyapp (tycon "Q") (tycon "Type")) `tyfun`+ (tycon "String" `tyfun`+ (tyapp (tycon "Q") (tylist (tycon "Dec"))))+ rhs = doE [qtypstmt, genstmt, letStmt lststmt, qualStmt retstmt]+ qtypstmt = generator (p "typ") (v "qtyp")+ genstmt = generator+ (p "f1")+ (v "mkMember" `app` ( strE (hsTemplateMemberFunctionName c f <> "_")+ `app` v "<>"+ `app` v "suffix"+ )+ `app` v (hsTemplateMemberFunctionNameTH c f)+ `app` v "typ"+ `app` v "suffix"+ )+ lststmt = [ pbind (p "lst") (list ([v "f1"])) Nothing ]+ retstmt = v "pure" `app` v "lst"++--------------------+-- Template Class --+--------------------++genTmplInterface :: TemplateClass -> [Decl ()]+genTmplInterface t =+ [ mkData rname [mkTBind tp] [] Nothing+ , mkNewtype hname [mkTBind tp]+ [ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing+ , mkClass cxEmpty (typeclassNameT t) [mkTBind tp] methods+ , mkInstance cxEmpty "FPtr" [ hightype ] fptrbody+ , mkInstance cxEmpty "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 = mkFunSig (hsTmplFuncName t f) (functionSignatureT t f)+ methods = map (clsDecl . sigdecl) fs+ fptrbody = [ insType (tyapp (tycon "Raw") hightype) rawtype+ , insDecl (mkBind1 "get_fptr" [pApp (name 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 "typ", p "suffix"] rhs (Just bstmts)+ where nh = hsTmplFuncNameTH t f+ nc = ffiTmplFuncName f+ sig = tycon "Type" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tycon "Exp")))+ v = mkVar+ p = mkPVar+ tp = tclass_param t+ prefix = tclass_name t+ lit' = strE (prefix<>"_"<>nc<>"_")+ lam = lambda [p "n"] ( lit' `app` v "<>" `app` v "n")+ rhs = app (v "mkTFunc") (tuple [v "typ", v "suffix", lam, v "tyf"])+ sig' = functionSignatureTT t f+ bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]+ (letE [ pbind (p tp) (v "pure" `app` (v "typ")) Nothing ]+ (bracketExp (typeBracket sig')))+ Nothing+ ]+++genTmplInstance :: TemplateClass -> [TemplateFunction] -> [Decl ()]+genTmplInstance t fs = mkFun fname sig [p "qtyp", p "suffix"] rhs Nothing+ where tname = tclass_name t+ fname = "gen" <> tname <> "InstanceFor"+ p = mkPVar+ v = mkVar+ sig = (tyapp (tycon "Q") (tycon "Type")) `tyfun`+ (tycon "String" `tyfun`+ (tyapp (tycon "Q") (tylist (tycon "Dec"))))+ nfs = zip ([1..] :: [Int]) fs+ rhs = doE ( [qtypstmt]+ <> map genstmt nfs+ <> [letStmt (lststmt nfs), qualStmt retstmt])+ qtypstmt = generator (p "typ") (v "qtyp")+ genstmt (n,f@TFun {..}) = generator+ (p ("f"<>show n))+ (v "mkMember" `app` strE (hsTmplFuncName t f)+ `app` v (hsTmplFuncNameTH t f)+ `app` v "typ"+ `app` v "suffix"+ )+ genstmt (n,f@TFunNew {..}) = generator+ (p ("f"<>show n))+ (v "mkNew" `app` strE (hsTmplFuncName t f)+ `app` v (hsTmplFuncNameTH t f)+ `app` v "typ"+ `app` v "suffix"+ )+ genstmt (n,f@TFunDelete) = generator+ (p ("f"<>show n))+ (v "mkDelete" `app` strE (hsTmplFuncName t f)+ `app` v (hsTmplFuncNameTH t f)+ `app` v "typ"+ `app` v "suffix"+ )+ lststmt xs = [ pbind (p "lst") (list (map (v . (\n->"f"<>show n) . fst) xs)) Nothing ]+ retstmt = v "pure"+ `app` list [ v "mkInstance"+ `app` list []+ `app` (con "AppT"+ `app` (v "con" `app` strE (typeclassNameT t))+ `app` (v "typ")+ )+ `app` (v "lst")+ ]
− lib/FFICXX/Generate/Code/MethodDef.hs
@@ -1,157 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---------------------------------------------------------------------------------- |--- Module : FFICXX.Generate.Code.MethodDef--- Copyright : (c) 2011-2016 Ian-Woo Kim------ License : BSD3--- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>--- Stability : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Code.MethodDef where--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 ## _t, Type>((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 to_nonconst<"<>str<>"_t,"<>str- <>">(&("<>callstr<>"));"- where str = class_name c'- CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str- <>">(new "<>str<>"("<>callstr<>"));"- where str = class_name c'-- TemplateApp _ _ _ -> "return (" <> callstr <> ");"- TemplateAppRef _ _ _ -> "return (&(" <> callstr <> "));" - TemplateType _ -> error "returnCpp: TemplateType"- TemplateParam _ ->- if b then "return (" <> callstr <> ");"- else "return to_nonconst<Type ## _t, Type>((Type *)&("- <> callstr <> ")) ;"------ Function Declaration and Definition--funcToDecl :: Class -> Function -> String -funcToDecl c func - | isNewFunc func || isStaticFunc 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 subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func)) - , ("funcname", aliasedFuncName c func) - , ("args", argsToString (genericFuncArgs func))- ]) ----funcsToDecls :: Class -> [Function] -> String -funcsToDecls c = intercalateWith connSemicolonBSlash (funcToDecl c)---funcToDef :: Class -> Function -> String-funcToDef c func - | isNewFunc func = - let declstr = funcToDecl c func- callstr = "(" <> argsToCallString (genericFuncArgs func) <> ")"- returnstr = "Type * newp = new Type " <> callstr <> "; \\\nreturn to_nonconst<Type ## _t, Type >(newp);"- in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] - | isDeleteFunc func = - let declstr = funcToDecl c func- returnstr = "delete (to_nonconst<Type,Type ## _t>(p)) ; "- in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] - | isStaticFunc func = - let declstr = funcToDecl c func- callstr = cppFuncName c func <> "("- <> argsToCallString (genericFuncArgs func) - <> ")"- returnstr = returnCpp False (genericFuncRet func) callstr- in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] - | otherwise = - let declstr = funcToDecl c func- 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, "}"] ----funcsToDefs :: Class -> [Function] -> String-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 <> "<Type>*>(p))->"- <> tfun_oname <> "("- <> tmplAllArgsToCallString tfun_args - <> ")"- TFunNew {..} -> "new " <> tclass_oname <> "<Type>("- <> tmplAllArgsToCallString tfun_new_args- <> ")"- TFunDelete -> "delete (reinterpret_cast<" <> tclass_oname <> "<Type>*>(p))"- - returnstr =- case f of- TFunNew {..} -> "return reinterpret_cast<void*>("<>callstr<>");"- TFunDelete -> callstr <> ";"- TFun {..} -> returnCpp b (tfun_ret) callstr----
+ lib/FFICXX/Generate/Code/Primitive.hs view
@@ -0,0 +1,814 @@+{-# LANGUAGE RecordWildCards #-}+module FFICXX.Generate.Code.Primitive where++import Control.Monad.Trans.State (runState,put,get)+import Data.Monoid ((<>))+import Language.Haskell.Exts.Syntax (Asst(..),Context,Type(..))+--+import FFICXX.Generate.Name+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Util+import FFICXX.Generate.Util.HaskellSrcExts++data CFunSig = CFunSig { cArgTypes :: Args+ , cRetType :: Types+ }++data HsFunSig = HsFunSig { hsSigTypes :: [Type ()]+ , hsSigConstraints :: [Asst ()]+ }++cvarToStr :: CTypes -> IsConst -> String -> String+cvarToStr ctyp isconst varname = ctypToStr ctyp isconst <> " " <> varname++ctypToStr :: CTypes -> IsConst -> String+ctypToStr ctyp isconst =+ let typword = case ctyp of+ CTString -> "char*"+ CTChar -> "char"+ CTInt -> "int"+ CTUInt -> "unsigned int"+ CTLong -> "signed long"+ CTULong -> "long unsigned int"+ CTDouble -> "double"+ CTBool -> "int" -- Currently available solution+ CTDoubleStar -> "double *"+ CTVoidStar -> "void*"+ CTIntStar -> "int*"+ CTCharStarStar -> "char**"+ CPointer s -> ctypToStr s NoConst <> "*"+ CRef s -> ctypToStr s NoConst <> "*"+ in case isconst of+ Const -> "const" <> " " <> typword+ NoConst -> typword++self_ :: Types+self_ = SelfType++cstring_ :: Types+cstring_ = CT CTString Const++cint_ :: Types+cint_ = CT CTInt Const++int_ :: Types+int_ = CT CTInt NoConst++uint_ :: Types+uint_ = CT CTUInt NoConst++ulong_ :: Types+ulong_ = CT CTULong NoConst++long_ :: Types+long_ = CT CTLong NoConst++culong_ :: Types+culong_ = CT CTULong Const++clong_ :: Types+clong_ = CT CTLong Const++cchar_ :: Types+cchar_ = CT CTChar Const++char_ :: Types+char_ = CT CTChar NoConst++short_ :: Types+short_ = int_++cdouble_ :: Types+cdouble_ = CT CTDouble Const++double_ :: Types+double_ = CT CTDouble NoConst++doublep_ :: Types+doublep_ = CT CTDoubleStar NoConst++float_ :: Types+float_ = double_++bool_ :: Types+bool_ = CT CTBool NoConst++void_ :: Types+void_ = Void++voidp_ :: Types+voidp_ = CT CTVoidStar NoConst++intp_ :: Types+intp_ = CT CTIntStar NoConst++intref_ :: Types+intref_ = CT (CRef CTInt) NoConst+++charpp_ :: Types+charpp_ = CT CTCharStarStar NoConst++ref_ :: CTypes -> Types+ref_ t = CT (CRef t) NoConst++star_ :: CTypes -> Types+star_ t = CT (CPointer t) NoConst++cstar_ :: CTypes -> Types+cstar_ t = CT (CPointer t) Const++self :: String -> (Types, String)+self var = (self_, var)++voidp :: String -> (Types,String)+voidp var = (voidp_ , var)++cstring :: String -> (Types,String)+cstring var = (cstring_ , var)++cint :: String -> (Types,String)+cint var = (cint_ , var)++int :: String -> (Types,String)+int var = (int_ , var)++uint :: String -> (Types,String)+uint var = (uint_ , var)++long :: String -> (Types,String)+long var = (long_, var)++ulong :: String -> (Types,String)+ulong var = (ulong_ , var)++clong :: String -> (Types,String)+clong var = (clong_, var)++culong :: String -> (Types,String)+culong var = (culong_ , var)++cchar :: String -> (Types,String)+cchar var = (cchar_ , var)++char :: String -> (Types,String)+char var = (char_ , var)++short :: String -> (Types,String)+short = int++cdouble :: String -> (Types,String)+cdouble var = (cdouble_ , var)++double :: String -> (Types,String)+double var = (double_ , var)++doublep :: String -> (Types,String)+doublep var = (doublep_ , var)++float :: String -> (Types,String)+float = double++bool :: String -> (Types,String)+bool var = (bool_ , var)++intp :: String -> (Types, String)+intp var = (intp_ , var)++intref :: String -> (Types, String)+intref var = (intref_, var)++charpp :: String -> (Types, String)+charpp var = (charpp_, var)++ref :: CTypes -> String -> (Types,String)+ref t var = (ref_ t, var)++star :: CTypes -> String -> (Types, String)+star t var = (star_ t, var)++cstar :: CTypes -> String -> (Types, String)+cstar t var = (cstar_ t, var)+++cppclass_ :: Class -> Types+cppclass_ c = CPT (CPTClass c) NoConst++cppclass :: Class -> String -> (Types, String)+cppclass c vname = ( cppclass_ c, vname)++++cppclassconst :: Class -> String -> (Types, String)+cppclassconst c vname = ( CPT (CPTClass c) Const, vname)++cppclassref_ :: Class -> Types+cppclassref_ c = CPT (CPTClassRef c) NoConst++cppclassref :: Class -> String -> (Types, String)+cppclassref c vname = (cppclassref_ c, vname)++cppclasscopy_ :: Class -> Types+cppclasscopy_ c = CPT (CPTClassCopy c) NoConst++cppclasscopy :: Class -> String -> (Types, String)+cppclasscopy c vname = (cppclasscopy_ c, vname)++cppclassmove_ :: Class -> Types+cppclassmove_ c = CPT (CPTClassMove c) NoConst++cppclassmove :: Class -> String -> (Types, String)+cppclassmove c vname = (cppclassmove_ c, vname)+++argToString :: (Types,String) -> String+argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname+argToString (SelfType, varname) = "Type ## _p " <> varname+argToString (CPT (CPTClass c) isconst, varname) = case isconst of+ Const -> "const_" <> cname <> "_p " <> varname+ NoConst -> cname <> "_p " <> varname+ where cname = ffiClassName c+argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of+ Const -> "const_" <> cname <> "_p " <> varname+ NoConst -> cname <> "_p " <> varname+ where cname = ffiClassName c+argToString (CPT (CPTClassCopy c) isconst, varname) = case isconst of+ Const -> "const_" <> cname <> "_p " <> varname+ NoConst -> cname <> "_p " <> varname+ where cname = ffiClassName c+argToString (CPT (CPTClassMove c) isconst, varname) = case isconst of+ Const -> "const_" <> cname <> "_p " <> varname+ NoConst -> cname <> "_p " <> varname+ where cname = ffiClassName c+argToString (TemplateApp _, varname) = "void* " <> varname+argToString (TemplateAppRef _, varname) = "void* " <> varname+argToString (TemplateAppMove _, varname) = "void* " <> varname+argToString t = error ("argToString: " <> show t)++argsToString :: Args -> String+argsToString args =+ let args' = (SelfType, "p") : args+ in intercalateWith conncomma argToString args'++argsToStringNoSelf :: Args -> String+argsToStringNoSelf = intercalateWith conncomma argToString++-- TODO: remove this function+argToCallString :: (Types,String) -> String+argToCallString = uncurry castC2Cpp+++argsToCallString :: Args -> String+argsToCallString = intercalateWith conncomma argToCallString++-- TODO: rename this function by castExpressionFrom/To or something like that.+rettypeToString :: Types -> String+rettypeToString (CT ctyp isconst) = ctypToStr ctyp isconst+rettypeToString Void = "void"+rettypeToString SelfType = "Type ## _p"+rettypeToString (CPT (CPTClass c) _) = ffiClassName c <> "_p"+rettypeToString (CPT (CPTClassRef c) _) = ffiClassName c <> "_p"+rettypeToString (CPT (CPTClassCopy c) _) = ffiClassName c <> "_p"+rettypeToString (CPT (CPTClassMove c) _) = ffiClassName c <> "_p"+rettypeToString (TemplateApp _) = "void*"+rettypeToString (TemplateAppRef _) = "void*"+rettypeToString (TemplateAppMove _) = "void*"+rettypeToString (TemplateType _) = "void*"+rettypeToString (TemplateParam _) = "Type ## _p"+rettypeToString (TemplateParamPointer _) = "Type ## _p"++++-- TODO: Rewrite this with static_cast+castC2Cpp :: Types -> String -> String+castC2Cpp t e =+ case t of+ CT (CRef _) _ -> "(*"<> e <> ")"+ CPT (CPTClass c) _ -> "to_nonconst<" <> f <> "," <> f <> "_t>(" <> e <> ")"+ where f = ffiClassName c+ CPT (CPTClassRef c) _ -> "to_nonconstref<" <> f <> "," <> f <> "_t>(*" <> e <> ")"+ where f = ffiClassName c+ CPT (CPTClassCopy c) _ -> "*(to_nonconst<" <> f <> "," <> f <> "_t>(" <> e <> "))"+ where f = ffiClassName c+ CPT (CPTClassMove c) _ -> "std::move(to_nonconstref<" <> f <> "," <> f<> "_t>(*" <> e <> "))"+ where f = ffiClassName c+ TemplateApp p -> "to_nonconst<" <> tapp_CppTypeForParam p <> ",void>(" <> e <> ")"+ TemplateAppRef p -> "*( (" <> tapp_CppTypeForParam p <> "*) " <> e <> ")"+ TemplateAppMove p -> "std::move(*( (" <> tapp_CppTypeForParam p <> "*) " <> e <> "))"+ _ -> e+++-- TODO: Rewrite this with static_cast+-- Merge this with returnCpp after Void and simple type adjustment+castCpp2C :: Types -> String -> String+castCpp2C t e =+ case t of+ Void -> ""+ SelfType -> "to_nonconst<Type ## _t, Type>((Type *)" <> e <> ")"+ CT (CRef _) _ -> "&(" <> e <> ")"+ CT _ _ -> e+ CPT (CPTClass c) _ -> "to_nonconst<" <> f <> "_t," <> f <> ">((" <> f <> "*)" <> e <> ")"+ where f = ffiClassName c+ CPT (CPTClassRef c) _ -> "to_nonconst<" <> f <> "_t," <> f <> ">(&(" <> e <> "))"+ where f = ffiClassName c+ CPT (CPTClassCopy c) _ -> "to_nonconst<" <> f <> "_t," <> f <> ">(new " <> f <> "(" <> e <> "))"+ where f = ffiClassName c+ CPT (CPTClassMove c) _ -> "std::move(to_nonconst<" <> f <> "_t," <> f <>">(&(" <> e <> ")))"+ where f = ffiClassName c+ TemplateApp _ -> error "castCpp2C: TemplateApp"+ -- g <> "* r = new " <> g <> "(" <> e <> "); "+ -- <> "return (static_cast<void*>(r));"+ TemplateAppRef _ -> error "castCpp2C: TemplateAppRef"+ -- g <> "* r = new " <> g <> "(" <> e <> "); "+ -- <> "return (static_cast<void*>(r));"+ TemplateAppMove _ -> error "castCpp2C: TemplateAppMove"+ TemplateType _ -> error "castCpp2C: TemplateType"+ TemplateParam _ -> error "castCpp2C: TemplateParam"+ -- if b then e+ -- else "to_nonconst<Type ## _t, Type>((Type *)&(" <> e <> "))"+ TemplateParamPointer _ -> error "castCpp2C: TemplateParamPointer"+ -- if b then "(" <> callstr <> ");"+ -- else "to_nonconst<Type ## _t, Type>(" <> e <> ") ;"++++tmplArgToString :: Bool -> 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_" <> ffiClassName c <> "_p " <> varname+ NoConst -> ffiClassName c <> "_p " <> varname+tmplArgToString _ _ (CPT (CPTClassRef c) isconst, varname) =+ case isconst of+ Const -> "const_" <> ffiClassName c <> "_p " <> varname+ NoConst -> ffiClassName c <> "_p " <> varname+tmplArgToString _ _ (CPT (CPTClassMove c) isconst, varname) =+ case isconst of+ Const -> "const_" <> ffiClassName c <> "_p " <> varname+ NoConst -> ffiClassName c <> "_p " <> varname+tmplArgToString _ _ (TemplateApp _, v) = "void* " <> v+tmplArgToString _ _ (TemplateAppRef _, v) = "void* " <> v+tmplArgToString _ _ (TemplateAppMove _, v) = "void* " <> v+tmplArgToString _ _ (TemplateType _, v) = "void* " <> v+tmplArgToString True _ (TemplateParam _,v) = "Type " <> v+tmplArgToString False _ (TemplateParam _,v) = "Type ## _p " <> v+tmplArgToString True _ (TemplateParamPointer _,v) = "Type " <> v+tmplArgToString False _ (TemplateParamPointer _,v) = "Type ## _p " <> v+tmplArgToString _ _ _ = error "tmplArgToString: undefined"++tmplAllArgsToString :: Bool+ -> Selfness+ -> TemplateClass+ -> Args+ -> String+tmplAllArgsToString b s t args =+ let args' = case s of+ Self -> (TemplateType t, "p") : args+ NoSelf -> args+ in intercalateWith conncomma (tmplArgToString b t) args'++++tmplArgToCallString+ :: Bool -- ^ is primitive type?+ -> (Types,String)+ -> String+tmplArgToCallString _ (CPT (CPTClass c) _,varname) =+ -- TODO: Rewrite this with static_cast.+ "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = ffiClassName c+tmplArgToCallString _ (CPT (CPTClassRef c) _,varname) =+ -- TODO: Rewrite this with static_cast.+ "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = ffiClassName c+tmplArgToCallString _ (CPT (CPTClassMove c) _,varname) =+ -- TODO: Rewrite this with static_cast.+ "std::move(to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>"))" where str = ffiClassName c+tmplArgToCallString _ (CT (CRef _) _,varname) = "(*"<> varname<> ")"+tmplArgToCallString _ (TemplateApp x,varname) =+ case tapp_tparam x of+ TArg_TypeParam p -> "static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> ")"+ _ -> -- TODO: Implement this.+ error "tmplArgToCallString: TemplateApp"+tmplArgToCallString _ (TemplateAppRef x,varname) =+ case tapp_tparam x of+ TArg_TypeParam p -> "*" <> "(static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> "))"+ _ -> -- TODO: Implement this.+ error "tmplArgToCallString: TemplateAppRef"+tmplArgToCallString _ (TemplateAppMove x,varname) =+ case tapp_tparam x of+ TArg_TypeParam p -> "std::move(*" <> "(static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> ")))"+ _ -> -- TODO: Implement this.+ error "tmplArgToCallString: TemplateAppMove"+tmplArgToCallString b (TemplateParam _,varname) =+ case b of+ True -> varname+ False -> "*(to_nonconst<Type,Type ## _t>(" <> varname <> "))"+tmplArgToCallString b (TemplateParamPointer _,varname) =+ case b of+ True -> varname+ False -> "to_nonconst<Type,Type ## _t>(" <> varname <> ")"+tmplArgToCallString _ (_,varname) = varname++tmplAllArgsToCallString+ :: Bool -- ^ is primitive type?+ -> Args+ -> String+tmplAllArgsToCallString b = intercalateWith conncomma (tmplArgToCallString b)++++tmplRetTypeToString :: Bool -- ^ is primitive type?+ -> Types+ -> String+tmplRetTypeToString _ (CT ctyp isconst) = ctypToStr ctyp isconst+tmplRetTypeToString _ Void = "void"+tmplRetTypeToString _ SelfType = "void*"+tmplRetTypeToString _ (CPT (CPTClass c) _) = ffiClassName c <> "_p"+tmplRetTypeToString _ (CPT (CPTClassRef c) _) = ffiClassName c <> "_p"+tmplRetTypeToString _ (CPT (CPTClassCopy c) _) = ffiClassName c <> "_p"+tmplRetTypeToString _ (CPT (CPTClassMove c) _) = ffiClassName c <> "_p"+tmplRetTypeToString _ (TemplateApp _) = "void*"+tmplRetTypeToString _ (TemplateAppRef _) = "void*"+tmplRetTypeToString _ (TemplateAppMove _) = "void*"+tmplRetTypeToString _ (TemplateType _) = "void*"+tmplRetTypeToString b (TemplateParam _) = if b then "Type" else "Type ## _p"+tmplRetTypeToString b (TemplateParamPointer _) = if b then "Type" else "Type ## _p"++++++-- ---------------------------+-- Template Member Function --+-- ---------------------------++tmplMemFuncArgToString :: Class -> (Types,String) -> String+tmplMemFuncArgToString _ (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname+tmplMemFuncArgToString c (SelfType, varname) = ffiClassName c <> "_p " <> varname+tmplMemFuncArgToString _ (CPT (CPTClass c) isconst, varname) =+ case isconst of+ Const -> "const_" <> ffiClassName c <> "_p " <> varname+ NoConst -> ffiClassName c <> "_p " <> varname+tmplMemFuncArgToString _ (CPT (CPTClassRef c) isconst, varname) =+ case isconst of+ Const -> "const_" <> ffiClassName c <> "_p " <> varname+ NoConst -> ffiClassName c <> "_p " <> varname+tmplMemFuncArgToString _ (CPT (CPTClassMove c) isconst, varname) =+ case isconst of+ Const -> "const_" <> ffiClassName c <> "_p " <> varname+ NoConst -> ffiClassName c <> "_p " <> varname+tmplMemFuncArgToString _ (TemplateApp _, v) = "void* " <> v+tmplMemFuncArgToString _ (TemplateAppRef _, v) = "void* " <> v+tmplMemFuncArgToString _ (TemplateAppMove _, v) = "void* " <> v+tmplMemFuncArgToString _ (TemplateType _, v) = "void* " <> v+tmplMemFuncArgToString _ (TemplateParam _,v) = "Type##_p " <> v+tmplMemFuncArgToString _ (TemplateParamPointer _,v) = "Type##_p " <> v+tmplMemFuncArgToString _ _ = error "tmplMemFuncArgToString: undefined"+++tmplMemFuncRetTypeToString :: Class -> Types -> String+tmplMemFuncRetTypeToString _ (CT ctyp isconst) = ctypToStr ctyp isconst+tmplMemFuncRetTypeToString _ Void = "void"+tmplMemFuncRetTypeToString c SelfType = ffiClassName c <> "_p"+tmplMemFuncRetTypeToString _ (CPT (CPTClass c) _) = ffiClassName c <> "_p"+tmplMemFuncRetTypeToString _ (CPT (CPTClassRef c) _) = ffiClassName c <> "_p"+tmplMemFuncRetTypeToString _ (CPT (CPTClassCopy c) _) = ffiClassName c <> "_p"+tmplMemFuncRetTypeToString _ (CPT (CPTClassMove c) _) = ffiClassName c <> "_p"+tmplMemFuncRetTypeToString _ (TemplateApp _) = "void*"+tmplMemFuncRetTypeToString _ (TemplateAppRef _) = "void*"+tmplMemFuncRetTypeToString _ (TemplateAppMove _) = "void*"+tmplMemFuncRetTypeToString _ (TemplateType _) = "void*"+tmplMemFuncRetTypeToString _ (TemplateParam _) = "Type##_p"+tmplMemFuncRetTypeToString _ (TemplateParamPointer _) = "Type##_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 (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c'+convertCpp2HS _c (TemplateApp x) = tyapp+ (tycon (tclass_name (tapp_tclass x)))+ (tycon (hsClassNameForTArg (tapp_tparam x)))+convertCpp2HS _c (TemplateAppRef x) = tyapp+ (tycon (tclass_name (tapp_tclass x)))+ (tycon (hsClassNameForTArg (tapp_tparam x)))+convertCpp2HS _c (TemplateAppMove x) = tyapp+ (tycon (tclass_name (tapp_tclass x)))+ (tycon (hsClassNameForTArg (tapp_tparam x)))+convertCpp2HS _c (TemplateType t) = tyapp+ (tycon (tclass_name t))+ (mkTVar (tclass_param t))+convertCpp2HS _c (TemplateParam p) = mkTVar p+convertCpp2HS _c (TemplateParamPointer p) = mkTVar p++-- |+convertCpp2HS4Tmpl+ :: Type () -- ^ self+ -> Maybe Class+ -> Type () -- ^ type paramemter splice+ -> 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 _ _c _ (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c'+convertCpp2HS4Tmpl e c s x@(TemplateApp p) =+ case tapp_tparam p of+ TArg_TypeParam _ -> let t = tapp_tclass p+ (hname,_) = hsTemplateClassName t+ in tyapp (tycon hname) s+ _ -> convertCpp2HS c x+convertCpp2HS4Tmpl e c s x@(TemplateAppRef p) =+ case tapp_tparam p of+ TArg_TypeParam _ -> let t = tapp_tclass p+ (hname,_) = hsTemplateClassName t+ in tyapp (tycon hname) s+ _ -> convertCpp2HS c x+convertCpp2HS4Tmpl e c s x@(TemplateAppMove p) =+ case tapp_tparam p of+ TArg_TypeParam _ -> let t = tapp_tclass p+ (hname,_) = hsTemplateClassName t+ in tyapp (tycon hname) s+ _ -> convertCpp2HS c x+convertCpp2HS4Tmpl e _c _ (TemplateType _) = e+convertCpp2HS4Tmpl _ _c s (TemplateParam _) = s+convertCpp2HS4Tmpl _ _c s (TemplateParamPointer _) = s+++hsFuncXformer :: Function -> String+hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func)+ in if len > 0+ then "xform" <> show (len - 1)+ else "xformnull"+hsFuncXformer func@(Static _ _ _ _) =+ let len = length (genericFuncArgs func)+ in if len > 0+ then "xform" <> show (len - 1)+ else "xformnull"+hsFuncXformer func = let len = length (genericFuncArgs func)+ in "xform" <> show len++++classConstraints :: Class -> Context ()+classConstraints = cxTuple . map ((\n->classA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents++extractArgRetTypes+ :: Maybe Class -- ^ class (Nothing for top-level function)+ -> Bool -- ^ is virtual function?+ -> CFunSig -- ^ C type signature information for a given function -- (Args,Types) -- ^ (argument types, return type) of a given function+ -> HsFunSig -- ^ Haskell type signature information for the function -- ([Type ()],[Asst ()]) -- ^ (types, class constraints)+extractArgRetTypes mc isvirtual (CFunSig 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 . convertCpp2HS Nothing) x+ return (as ++ [tyapp (tycon "IO") r])+ in HsFunSig { hsSigTypes = typs+ , hsSigConstraints = 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 $ convertCpp2HS Nothing typ+ CPT (CPTClass c') _ -> addclass c'+ CPT (CPTClassRef c') _ -> addclass c'+ CPT (CPTClassCopy c') _ -> addclass c'+ CPT (CPTClassMove c') _ -> addclass c'+ -- it is not clear whether the following is okay or not.+ (TemplateApp x) -> pure $+ tyapp+ (tycon (tclass_name (tapp_tclass x)))+ (tycon (hsClassNameForTArg (tapp_tparam x)))+ (TemplateAppRef x) -> pure $+ tyapp+ (tycon (tclass_name (tapp_tclass x)))+ (tycon (hsClassNameForTArg (tapp_tparam x)))+ (TemplateAppMove x)-> pure $+ tyapp+ (tycon (tclass_name (tapp_tclass x)))+ (tycon (hsClassNameForTArg (tapp_tparam x)))+ (TemplateType t) -> pure $+ 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 HsFunSig typs assts = extractArgRetTypes+ (Just c)+ (isVirtualFunc f)+ (CFunSig (genericFuncArgs f) (genericFuncRet f))+ ctxt = cxTuple assts+ arg0+ | isVirtualFunc f = (mkTVar "a" :)+ | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :)+ | otherwise = id+ in TyForall () Nothing (Just ctxt) (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)++++-- TODO: rename this and combine this with functionSignatureTMF+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]++-- TODO: rename this and combine this with functionSignatureTT+functionSignatureTMF :: Class -> TemplateMemberFunction -> Type ()+functionSignatureTMF c f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])+ where+ ctyp = convertCpp2HS4Tmpl e Nothing spl (tmf_ret f)+ e = tycon (fst (hsClassName c))+ spl = tySplice (parenSplice (mkVar (tmf_param f)))+ lst = e : map (convertCpp2HS4Tmpl e Nothing spl . fst) (tmf_args f)+++accessorCFunSig :: Types -> Accessor -> CFunSig+accessorCFunSig typ Getter = CFunSig [] typ+accessorCFunSig typ Setter = CFunSig [(typ,"x")] Void+++accessorSignature :: Class -> Variable -> Accessor -> Type ()+accessorSignature c v accessor =+ let csig = accessorCFunSig (var_type v) accessor+ HsFunSig typs assts = extractArgRetTypes (Just c) False csig+ ctxt = cxTuple assts+ arg0 = (mkTVar (fst (hsClassName c)) :)+ in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs))+++-- | this is for FFI type.+hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type ()+hsFFIFuncTyp msc (CFunSig 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 :: [Type ()]+ argtyps = map (hsargtype . fst) args+ rettyp :: Type ()+ 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 :: Types -> Type ()+ hsargtype (CT ctype _) = convertC2HS 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 (CPT (CPTClassMove d) _) = tyapp tyPtr (tycon rawname)+ where rawname = snd (hsClassName d)+ hsargtype (CPT (CPTClassCopy d) _) = tyapp tyPtr (tycon rawname)+ where rawname = snd (hsClassName d)+ hsargtype (TemplateApp x) = tyapp+ tyPtr+ (tyapp+ (tycon rawname)+ (tycon (hsClassNameForTArg (tapp_tparam x))))+ where rawname = snd (hsTemplateClassName (tapp_tclass x))+ hsargtype (TemplateAppRef x) = tyapp+ tyPtr+ (tyapp+ (tycon rawname)+ (tycon (hsClassNameForTArg (tapp_tparam x))))+ where rawname = snd (hsTemplateClassName (tapp_tclass x))+ hsargtype (TemplateAppMove x)= tyapp+ tyPtr+ (tyapp+ (tycon rawname)+ (tycon (hsClassNameForTArg (tapp_tparam x))))+ where rawname = snd (hsTemplateClassName (tapp_tclass x))+ 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 _) = convertC2HS 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 (CPT (CPTClassMove d) _) = tyapp tyPtr (tycon rawname)+ where rawname = snd (hsClassName d)+ hsrettype (TemplateApp x) = tyapp+ tyPtr+ (tyapp+ (tycon rawname)+ (tycon (hsClassNameForTArg (tapp_tparam x))))+ where rawname = snd (hsTemplateClassName (tapp_tclass x))+ hsrettype (TemplateAppRef x) = tyapp+ tyPtr+ (tyapp+ (tycon rawname)+ (tycon (hsClassNameForTArg (tapp_tparam x))))+ where rawname = snd (hsTemplateClassName (tapp_tclass x))+ hsrettype (TemplateAppMove x)= tyapp+ tyPtr+ (tyapp+ (tycon rawname)+ (tycon (hsClassNameForTArg (tapp_tparam x))))+ where rawname = snd (hsTemplateClassName (tapp_tclass x))+ hsrettype (TemplateType t) = tyapp tyPtr (tyapp (tycon rawname) (mkTVar (tclass_param t)))+ where rawname = snd (hsTemplateClassName t)+ hsrettype (TemplateParam p) = mkTVar p+ hsrettype (TemplateParamPointer p) = mkTVar p++++genericFuncRet :: Function -> Types+genericFuncRet f =+ case f of+ Constructor _ _ -> self_+ Virtual t _ _ _ -> t+ NonVirtual t _ _ _-> t+ Static t _ _ _ -> t+ Destructor _ -> void_++genericFuncArgs :: Function -> Args+genericFuncArgs (Destructor _) = []+genericFuncArgs f = func_args f
lib/FFICXX/Generate/ContentMaker.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.ContentMaker--- Copyright : (c) 2011-2017 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -13,75 +13,89 @@ -- ----------------------------------------------------------------------------- -module FFICXX.Generate.ContentMaker where +module FFICXX.Generate.ContentMaker where -import Control.Lens ( set,at )+import Control.Lens ((&),(.~),at) import Control.Monad.Trans.Reader-import Data.Function ( on )+import Data.Char (toUpper)+import Data.Either (rights)+import Data.Function (on) import qualified Data.Map as M-import Data.Monoid ( (<>) )-import Data.List -import Data.List.Split ( splitOn ) +import Data.Monoid ((<>))+import Data.List (intercalate,nub,nubBy)+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 Data.Text (Text)+import Language.Haskell.Exts.Syntax (Module(..),Decl(..)) import System.FilePath--- +-- import FFICXX.Generate.Code.Cpp-import FFICXX.Generate.Code.HsFFI +import FFICXX.Generate.Code.HsCast (genHsFrontInstCastable+ ,genHsFrontInstCastableSelf)+import FFICXX.Generate.Code.HsFFI (genHsFFI+ ,genImportInFFI+ ,genTopLevelFuncFFI) import FFICXX.Generate.Code.HsFrontEnd+import FFICXX.Generate.Code.HsTemplate (genTemplateMemberFunctions+ ,genTmplInstance+ ,genTmplInterface+ ,genTmplImplementation+ )+import FFICXX.Generate.Dependency+import FFICXX.Generate.Name (ffiClassName,hsClassName+ ,hsFrontNameForTopLevelFunction) 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.Type.PackageInterface (ClassName(..),HeaderName(..)+ ,Namespace(..)+ ,PackageInterface,PackageName(..)+ ,TypeMacro(..)) import FFICXX.Generate.Util import FFICXX.Generate.Util.HaskellSrcExts -- + srcDir :: FilePath -> FilePath-srcDir installbasedir = installbasedir </> "src" +srcDir installbasedir = installbasedir </> "src" csrcDir :: FilePath -> FilePath-csrcDir installbasedir = installbasedir </> "csrc" +csrcDir installbasedir = installbasedir </> "csrc" ---- common function for daughter --- | +-- | mkGlobal :: [Class] -> ClassGlobal-mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap +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) +-- |+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 +-- |+mkProtectedFunctionList :: Class -> String+mkProtectedFunctionList c =+ (unlines+ . map (\x->"#define IS_" <> class_name c <> "_" <> x <> "_PROTECTED ()")+ . unProtected . class_protected) c -- |-buildTypeDeclHeader :: TypeMacro -- ^ typemacro +buildTypeDeclHeader :: TypeMacro -- ^ typemacro -> [Class]- -> String + -> String buildTypeDeclHeader (TypMcro typemacro) classes =- let typeDeclBodyStr = genAllCppHeaderTmplType classes + let typeDeclBodyStr = intercalateWith connRet2 (genCppHeaderMacroType) classes in subst "#ifdef __cplusplus\n\ \extern \"C\" { \n\@@ -96,14 +110,14 @@ \\n\ \#ifdef __cplusplus\n\ \}\n\- \#endif\n" - (context [ ("typeDeclBody", typeDeclBodyStr ) + \#endif\n"+ (context [ ("typeDeclBody", typeDeclBodyStr ) , ("typemacro" , typemacro ) ]) declarationTemplate :: Text-declarationTemplate = +declarationTemplate = "#ifdef __cplusplus\n\ \extern \"C\" { \n\ \#endif\n\@@ -111,10 +125,10 @@ \#ifndef $typemacro\n\ \#define $typemacro\n\ \\n\- \#include \"${cprefix}Type.h\"\- \\n\+ \#include \"${cprefix}Type.h\"\n\+ \ // \n\ \$declarationheader\n\- \\n\+ \ // \n\ \$declarationbody\n\ \\n\ \#endif // $typemacro\n\@@ -123,119 +137,160 @@ \}\n\ \#endif\n" --- | -buildDeclHeader :: TypeMacro -- ^ typemacro prefix - -> String -- ^ C prefix - -> ClassImportHeader - -> String +-- |+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 + typemacrostr = typemacroprefix <> ffiClassName aclass <> "__"+ declHeaderStr = intercalateWith+ connRet+ (\x->"#include \""<>x<>"\"")+ (map unHdrName (cihIncludedHPkgHeadersInH header))+ declDefStr = intercalateWith connRet2 genCppHeaderMacroVirtual classes `connRet2`- genAllCppHeaderTmplNonVirtual classes - `connRet2` - genAllCppDefTmplVirtual classes+ intercalateWith connRet genCppHeaderMacroNonVirtual classes `connRet2`- genAllCppDefTmplNonVirtual classes- classDeclsStr = if (fst.hsClassName) aclass /= "Deletable"- then buildParentDef genCppHeaderInstVirtual aclass + intercalateWith connRet genCppHeaderMacroAccessor classes+ `connRet2`+ intercalateWith connRet2 genCppDefMacroVirtual classes+ `connRet2`+ intercalateWith connRet2 genCppDefMacroNonVirtual classes+ `connRet2`+ intercalateWith connRet2 genCppDefMacroAccessor classes+ `connRet2`+ flip (intercalateWith connRet2) classes+ (\c -> intercalateWith connRet2+ (genCppDefMacroTemplateMemberFunction c)+ (class_tmpl_funcs c)+ )+ classDeclsStr = -- NOTE: Deletable is treated specially.+ -- TODO: We had better make it as a separate constructor in Class.+ if (fst.hsClassName) aclass /= "Deletable"+ then buildParentDef genCppHeaderInstVirtual aclass `connRet2` genCppHeaderInstVirtual (aclass, aclass)- `connRet2` - genAllCppHeaderInstNonVirtual classes- else "" - declBodyStr = declDefStr - `connRet2` - classDeclsStr + `connRet2`+ intercalateWith connRet genCppHeaderInstNonVirtual classes+ `connRet2`+ intercalateWith connRet genCppHeaderInstAccessor classes+ else ""+ declBodyStr = declDefStr+ `connRet2`+ classDeclsStr in subst declarationTemplate (context [ ("typemacro" , typemacrostr ) , ("cprefix" , cprefix )- , ("declarationheader", declHeaderStr ) + , ("declarationheader", declHeaderStr ) , ("declarationbody" , declBodyStr ) ]) definitionTemplate :: Text definitionTemplate =- "#include <MacroPatternMatch.h>\n\+ "#include<MacroPatternMatch.h>\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<oname,cname ## _t>), \\\n\- \ (to_nonconst<cname,cname ## _t>) )\n\+ \$alias\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) +-- |+buildDefMain :: ClassImportHeader+ -> String+buildDefMain cih =+ let classes = [cihClass cih]+ headerStr = genAllCppHeaderInclude cih <> "\n#include \"" <> (unHdrName (cihSelfHeader cih)) <> "\""+ namespaceStr = (concatMap (\x->"using namespace " <> unNamespace x <> ";\n") . cihNamespace) cih+ aclass = cihClass cih+ aliasStr = intercalate "\n" $+ mapMaybe typedefstmt $+ aclass : rights (cihImportedClasses cih)+ where typedefstmt c = let n1 = class_name c+ n2 = ffiClassName c+ in if n1 == n2+ then Nothing+ else Just ("typedef " <> n1 <> " " <> n2 <> ";")++ cppBody = mkProtectedFunctionList (cihClass cih) `connRet`- buildParentDef genCppDefInstVirtual (cihClass header)- `connRet` - if isAbstractClass aclass - then "" + buildParentDef genCppDefInstVirtual (cihClass cih)+ `connRet`+ if isAbstractClass aclass+ then "" else genCppDefInstVirtual (aclass, aclass) `connRet`- genAllCppDefInstNonVirtual classes+ intercalateWith connRet genCppDefInstNonVirtual classes+ `connRet`+ intercalateWith connRet genCppDefInstAccessor classes in subst definitionTemplate (context ([ ("header" , headerStr )+ , ("alias" , aliasStr ) , ("namespace", namespaceStr )- , ("cppbody" , cppBody ) ])) + , ("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+-- |+buildTopLevelHeader :: TypeMacro -- ^ typemacro prefix+ -> String -- ^ C prefix+ -> TopLevelImportHeader+ -> String+buildTopLevelHeader (TypMcro typemacroprefix) cprefix tih =+ let typemacrostr = typemacroprefix <> "TOPLEVEL" <> "__"+ declHeaderStr = intercalateWith connRet (\x->"#include \""<>x<>"\"") $+ map unHdrName $+ map cihSelfHeader (tihClassDep tih)+ ++ tihExtraHeadersInH tih declBodyStr = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih) in subst declarationTemplate (context [ ("typemacro" , typemacrostr ) , ("cprefix" , cprefix ) , ("declarationheader", declHeaderStr ) , ("declarationbody" , declBodyStr ) ]) --- | -buildTopLevelFunctionCppDef :: TopLevelImportHeader -> String -buildTopLevelFunctionCppDef tih =+-- |+buildTopLevelCppDef :: TopLevelImportHeader -> String+buildTopLevelCppDef tih = let cihs = tihClassDep tih+ extclasses = tihExtraClassDep 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 + otherHeaders+ otherHeaders =+ intercalateWith connRet (\x->"#include \""<>x<>"\"") $+ map unHdrName $+ map cihSelfHeader cihs+ ++ tihExtraHeadersInCPP tih++ allns = nubBy ((==) `on` unNamespace) ((tihClassDep tih >>= cihNamespace) ++ tihNamespaces tih)++ namespaceStr = do ns <- allns ("using namespace " <> unNamespace ns <> ";\n")+ aliasStr = intercalate "\n" $+ mapMaybe typedefstmt $+ rights (concatMap cihImportedClasses cihs ++ extclasses)+ where typedefstmt c = let n1 = class_name c+ n2 = ffiClassName c+ in if n1 == n2+ then Nothing+ else Just ("typedef " <> n1 <> " " <> n2 <> ";") declBodyStr = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih) in subst definitionTemplate (context [ ("header" , declHeaderStr) , ("namespace", namespaceStr )+ , ("alias" , aliasStr ) , ("cppbody" , declBodyStr ) ]) --- | -buildTemplateHeader :: TypeMacro -- ^ typemacro prefix - -- -> String -- ^ C prefix- -> TemplateClass- -> String +-- |+buildTemplateHeader :: TypeMacro -- ^ typemacro prefix+ -> TemplateClass+ -> String buildTemplateHeader (TypMcro typemacroprefix) t =- let typemacrostr = typemacroprefix <> "TEMPLATE" <> "__"+ let typemacrostr = typemacroprefix <> "TEMPLATE__" <> map toUpper (tclass_name t) <> "__" fs = tclass_funcs t deffunc = intercalateWith connRet (genTmplFunCpp False t) fs ++ "\n\n"@@ -254,9 +309,9 @@ ]) --- | +-- | buildFFIHsc :: ClassModule -> Module ()-buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody +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") ]@@ -265,26 +320,25 @@ 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"+ where rawtypeImports = [ 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" + , "ScopedTypeVariables" , "TypeFamilies", "TypeSynonymInstances" ]] ifaceImports ifaceBody@@ -295,51 +349,62 @@ , mkImport "FFICXX.Runtime.Cast" ] <> genImportInInterface m <> genExtraImport m- ifaceBody = - runReader (mapM genHsFrontDecl classes) amap + 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" ]+ castImports = [ mkImport "Foreign.Ptr"+ , mkImport "FFICXX.Runtime.Cast"+ , mkImport "System.IO.Unsafe" ] <> genImportInCast m- body = mapMaybe genHsFrontInstCastable classes+ body = mapMaybe genHsFrontInstCastable classes <> mapMaybe genHsFrontInstCastableSelf classes --- | +-- | buildImplementationHs :: AnnotateMap -> ClassModule -> Module () buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation") [ lang [ "EmptyDataDecls"- , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface"- , "IncoherentInstances" + , "FlexibleContexts"+ , "FlexibleInstances"+ , "ForeignFunctionInterface"+ , "IncoherentInstances" , "MultiParamTypeClasses" , "OverlappingInstances"- , "TypeFamilies", "TypeSynonymInstances"+ , "TemplateHaskell"+ , "TypeFamilies"+ , "TypeSynonymInstances" ] ] implImports implBody where classes = cmClass m- implImports = [ mkImport "FFICXX.Runtime.Cast"+ implImports = [ mkImport "Data.Monoid" -- for template member , mkImport "Data.Word" , mkImport "Foreign.C" , mkImport "Foreign.Ptr"- , mkImport "System.IO.Unsafe" ]+ , mkImport "Language.Haskell.TH" -- for template member+ , mkImport "Language.Haskell.TH.Syntax" -- for template member+ , mkImport "System.IO.Unsafe"+ , mkImport "FFICXX.Runtime.Cast"+ , mkImport "FFICXX.Runtime.TH" -- for template member+ ] <> genImportInImplementation m <> genExtraImport m f :: Class -> [Decl ()] f y = concatMap (flip genHsFrontInst y) (y:class_allparents y) - implBody = concatMap f classes+ implBody = concatMap f classes <> runReader (concat <$> mapM genHsFrontInstNew classes) amap <> concatMap genHsFrontInstNonVirtual classes <> concatMap genHsFrontInstStatic classes+ <> concatMap genHsFrontInstVariables classes+ <> concatMap genTemplateMemberFunctions classes buildTemplateHs :: TemplateClassModule -> Module () buildTemplateHs m = mkModule (tcmModule m <.> "Template")@@ -351,7 +416,7 @@ ] body where ts = tcmTemplateClasses m- body = concatMap genTmplInterface ts + body = concatMap genTmplInterface ts buildTHHs :: TemplateClassModule -> Module () buildTHHs m = mkModule (tcmModule m <.> "TH")@@ -370,63 +435,38 @@ 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 cxEmpty ('I':cname) [mkTBind "a"] [] ] --- | +-- | buildModuleHs :: ClassModule -> Module () buildModuleHs m = mkModuleE (cmModule m) [] (concatMap genExport (cmClass m)) (genImportInModule (cmClass m)) [] --- | -buildPkgHs :: String -> ([ClassModule],[TemplateClassModule]) -> TopLevelImportHeader -> String -buildPkgHs modname (mods,tmods) 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)- `connRet`- intercalateWith connRet- ((\x->"import " <> x <> ".Template").tcmModule) tmods- topLevelDefStr = intercalate "\n" (map (prettyPrint . genTopLevelFuncFFI tih) tfns)- `connRet2`- intercalate "\n\n" (map (intercalateWith connRet prettyPrint) (map genTopLevelFuncDef tfns))- in subst- "{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}\n\- \module $summarymod (\n\- \ $exportList\n\- \) where\n\- \\n\- \$importList\n\- \$topLevelDef\n"- (context [ ("summarymod" , modname )- , ("exportList" , exportListStr ) - , ("importList" , importListStr ) - , ("topLevelDef", topLevelDefStr) ])+-- |+buildTopLevelHs :: String -> ([ClassModule],[TemplateClassModule]) -> TopLevelImportHeader -> Module ()+buildTopLevelHs modname (mods,tmods) tih =+ mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody+ where+ tfns = tihFuncs tih+ pkgExtensions = [ lang [ "FlexibleContexts", "FlexibleInstances" ] ]+ pkgExports = map (emodule . cmModule) mods+ ++ map (evar . unqual . hsFrontNameForTopLevelFunction) tfns + pkgImports = genImportInTopLevel modname (mods,tmods) tih - + pkgBody = map (genTopLevelFuncFFI tih) tfns+ ++ concatMap genTopLevelFuncDef tfns+ -- |-buildPackageInterface :: PackageInterface - -> PackageName - -> [ClassImportHeader] +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-+buildPackageInterface pinfc pkgname = foldr f pinfc+ where f cih repo =+ let name = (class_name . cihClass) cih+ header = cihSelfHeader cih+ in repo & at (pkgname,ClsName name) .~ (Just header)
+ lib/FFICXX/Generate/Dependency.hs view
@@ -0,0 +1,430 @@+{-# LANGUAGE RecordWildCards #-}+-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Dependency+-- Copyright : (c) 2011-2018 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Dependency where++--+-- fficxx generates one module per one C++ class, and C++ class depends on other classes,+-- so we need to import other modules corresponding to C++ classes in the dependency list.+-- Calculating the import list from dependency graph is what this module does.++-- Previously, we have only `Class` type, but added `TemplateClass` recently. Therefore+-- we have to calculate dependency graph for both types of classes. So we needed to change+-- `Class` to `Either TemplateClass Class` in many of routines that calculates module import+-- list.++-- `Dep4Func` contains a list of classes (both ordinary and template types) that is needed+-- for the definition of a member function.+-- The goal of `extractClassDep...` functions are to extract Dep4Func, and from the definition+-- of a class or a template class, we get a list of `Dep4Func`s and then we deduplicate the+-- dependency class list and finally get the import list for the module corresponding to+-- a given class.+--++import Data.Either (rights)+import Data.Function (on)+import qualified Data.HashMap.Strict as HM+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Data.Monoid ((<>))+import System.FilePath+--+import FFICXX.Generate.Name (ffiClassName,hsClassName,hsTemplateClassName)+import FFICXX.Generate.Type.Cabal (AddCInc,AddCSrc,CabalName(..)+ ,cabal_moduleprefix,cabal_pkgname+ ,cabal_cheaderprefix,unCabalName)+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Config (ModuleUnit(..)+ ,ModuleUnitImports(..),emptyModuleUnitImports+ ,ModuleUnitMap(..))+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Type.PackageInterface+++-- utility functions++getcabal = either tclass_cabal class_cabal++getparents = either (const []) (map Right . class_parents)++-- TODO: replace tclass_name with appropriate FFI name when supported.+getFFIName = either tclass_name ffiClassName+++getPkgName :: Either TemplateClass Class -> CabalName+getPkgName = cabal_pkgname . getcabal+++-- |+extractClassFromType :: Types -> [Either TemplateClass Class]+extractClassFromType Void = []+extractClassFromType SelfType = []+extractClassFromType (CT _ _) = []+extractClassFromType (CPT (CPTClass c) _) = [Right c]+extractClassFromType (CPT (CPTClassRef c) _) = [Right c]+extractClassFromType (CPT (CPTClassCopy c) _) = [Right c]+extractClassFromType (CPT (CPTClassMove c) _) = [Right c]+extractClassFromType (TemplateApp (TemplateAppInfo t p _)) =+ (Left t): case p of+ TArg_Class c -> [Right c]+ _ -> []+extractClassFromType (TemplateAppRef (TemplateAppInfo t p _)) =+ (Left t): case p of+ TArg_Class c -> [Right c]+ _ -> []+extractClassFromType (TemplateAppMove (TemplateAppInfo t p _)) =+ (Left t): case p of+ TArg_Class c -> [Right c]+ _ -> []+extractClassFromType (TemplateType t) = [Left t]+extractClassFromType (TemplateParam _) = []+extractClassFromType (TemplateParamPointer _) = []+++class_allparents :: Class -> [Class]+class_allparents c = let ps = class_parents c+ in if null ps+ then []+ else nub (ps <> (concatMap class_allparents ps))+++getClassModuleBase :: Class -> String+getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (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+ where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)+ in foldl (addmeToYourDaughterList c) m ps+ addmeToYourDaughterList c m p = let f Nothing = Just [c]+ f (Just cs) = Just (c:cs)+ in M.alter f p m++++-- | Daughter Map including itself as a daughter+mkDaughterSelfMap :: [Class] -> DaughterMap+mkDaughterSelfMap = foldl' worker M.empty+ where worker m c = let ps = map getClassModuleBase (c:class_allparents c)+ in foldl (addToList c) m ps+ addToList c m p = let f Nothing = Just [c]+ f (Just cs) = Just (c:cs)+ in M.alter f p m++++-- | class dependency for a given function+data Dep4Func = Dep4Func { returnDependency :: [Either TemplateClass Class]+ , argumentDependency :: [Either TemplateClass Class] }+++-- |+extractClassDep :: Function -> Dep4Func+extractClassDep (Constructor args _) =+ Dep4Func [] (concatMap (extractClassFromType.fst) args)+extractClassDep (Virtual ret _ args _) =+ Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)+extractClassDep (NonVirtual ret _ args _) =+ Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)+extractClassDep (Static ret _ args _) =+ Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)+extractClassDep (Destructor _) =+ Dep4Func [] []+++extractClassDepForTmplFun :: TemplateFunction -> Dep4Func+extractClassDepForTmplFun (TFun ret _ _ args _) =+ Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)+extractClassDepForTmplFun (TFunNew args _) =+ Dep4Func [] (concatMap (extractClassFromType.fst) args)+extractClassDepForTmplFun TFunDelete =+ Dep4Func [] []+++extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func+extractClassDep4TmplMemberFun (TemplateMemberFunction {..}) =+ Dep4Func (extractClassFromType tmf_ret) (concatMap (extractClassFromType.fst) tmf_args)++++extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func+extractClassDepForTopLevelFunction f =+ Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)+ where ret = case f of+ TopLevelFunction {..} -> toplevelfunc_ret+ TopLevelVariable {..} -> toplevelvar_ret+ args = case f of+ TopLevelFunction {..} -> toplevelfunc_args+ TopLevelVariable {..} -> []+++-- TODO: Confirm the answer below is correct.+-- NOTE: Q: Why returnDependency only?+-- A: Difference between argument and return:+-- for a member function f,+-- we have (f :: (IA a, IB b) => a -> b -> IO C+-- return class is concrete and argument class is constraint.+mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class]+mkModuleDepRaw x@(Right c) =+ nub $+ filter (/= x) $+ concatMap (returnDependency . extractClassDep) (class_funcs c)+ ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)+mkModuleDepRaw x@(Left t) =+ (nub . filter (/= x) . concatMap (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t++++isNotInSamePackageWith+ :: Either TemplateClass Class+ -> Either TemplateClass Class+ -> Bool+isNotInSamePackageWith x y = (x /= y) && (getPkgName x /= getPkgName y)++-- x is in the sam+isInSamePackageButNotInheritedBy+ :: Either TemplateClass Class -- ^ y+ -> Either TemplateClass Class -- ^ x+ -> Bool+isInSamePackageButNotInheritedBy x y =+ x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y)+++-- TODO: Confirm the following answer+-- NOTE: Q: why returnDependency is not considered?+-- A: See explanation in mkModuleDepRaw+mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class]+mkModuleDepHighNonSource y@(Right c) =+ let extclasses = filter (`isNotInSamePackageWith` y) $+ concatMap (argumentDependency.extractClassDep) (class_funcs c)+ ++ concatMap (argumentDependency.extractClassDep4TmplMemberFun) (class_tmpl_funcs c)+ parents = map Right (class_parents c)+ in nub (parents <> extclasses)+mkModuleDepHighNonSource y@(Left t) =+ let fs = tclass_funcs t+ extclasses = filter (`isNotInSamePackageWith` y) $+ concatMap (argumentDependency.extractClassDepForTmplFun) fs+ in nub extclasses+++-- TODO: Confirm the following answer+-- NOTE: Q: why returnDependency is not considered?+-- A: See explanation in mkModuleDepRaw+mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class]+mkModuleDepHighSource y@(Right c) =+ nub $+ filter (`isInSamePackageButNotInheritedBy` y) $+ concatMap (argumentDependency . extractClassDep) (class_funcs c)+ ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)+mkModuleDepHighSource y@(Left t) =+ let fs = tclass_funcs t+ in nub $+ filter (`isInSamePackageButNotInheritedBy` y) $+ concatMap (argumentDependency . extractClassDepForTmplFun) fs++-- |+mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class]+mkModuleDepCpp y@(Right c) =+ let fs = class_funcs c+ vs = class_vars c+ tmfs = class_tmpl_funcs c+ in nub . filter (/= y) $+ concatMap (returnDependency.extractClassDep) fs+ <> concatMap (argumentDependency.extractClassDep) fs+ <> concatMap (extractClassFromType . var_type) vs+ <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs+ <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs+ <> getparents y+mkModuleDepCpp y@(Left t) =+ let fs = tclass_funcs t+ in nub . filter (/= y) $+ concatMap (returnDependency.extractClassDepForTmplFun) fs+ <> concatMap (argumentDependency.extractClassDepForTmplFun) fs+ <> getparents y++-- |+mkModuleDepFFI1 :: Either TemplateClass Class -> [Either TemplateClass Class]+mkModuleDepFFI1 (Right c) = let fs = class_funcs c+ vs = class_vars c+ tmfs = class_tmpl_funcs c+ in concatMap (returnDependency.extractClassDep) fs+ <> concatMap (argumentDependency.extractClassDep) fs+ <> concatMap (extractClassFromType . var_type) vs+ <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs+ <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs+mkModuleDepFFI1 (Left t) = let fs = tclass_funcs t+ in concatMap (returnDependency.extractClassDepForTmplFun) fs+ <> concatMap (argumentDependency.extractClassDepForTmplFun) fs++-- |+mkModuleDepFFI :: Either TemplateClass Class -> [Either TemplateClass Class]+mkModuleDepFFI y@(Right c) =+ let ps = map Right (class_allparents c)+ alldeps' = (concatMap mkModuleDepFFI1 ps) <> mkModuleDepFFI1 y+ in nub (filter (/= y) alldeps')+mkModuleDepFFI (Left _) = []+++mkClassModule :: (ModuleUnit -> ModuleUnitImports)+ -> [(String,[String])]+ -> Class+ -> ClassModule+mkClassModule getImports extra c =+ ClassModule {+ cmModule = getClassModuleBase c+ , cmClass = [c]+ , cmCIH = map (mkCIH getImports) [c]+ , cmImportedModulesHighNonSource = highs_nonsource+ , cmImportedModulesRaw =raws+ , cmImportedModulesHighSource = highs_source+ , cmImportedModulesForFFI = ffis+ , cmExtraImport = extraimports+ }+ where highs_nonsource = mkModuleDepHighNonSource (Right c)+ raws = mkModuleDepRaw (Right c)+ highs_source = mkModuleDepHighSource (Right c)+ ffis = mkModuleDepFFI (Right c)+ extraimports = fromMaybe [] (lookup (class_name c) extra)+++findModuleUnitImports :: ModuleUnitMap -> ModuleUnit -> ModuleUnitImports+findModuleUnitImports m u =+ fromMaybe emptyModuleUnitImports (HM.lookup u (unModuleUnitMap m))+++mkTCM :: (TemplateClass,HeaderName) -> TemplateClassModule+mkTCM (t,hdr) = TCM (getTClassModuleBase t) [t] [TCIH t hdr]+++mkPackageConfig+ :: (CabalName, ModuleUnit -> ModuleUnitImports) -- ^ (package name,getImports)+ -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])])+ -> [AddCInc]+ -> [AddCSrc]+ -> PackageConfig+mkPackageConfig (pkgname,getImports) (cs,fs,ts,extra) acincs acsrcs =+ let ms = map (mkClassModule getImports extra) cs+ cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)+ cihs = nubBy cmpfunc (concatMap cmCIH ms)+ --+ tih = mkTIH pkgname getImports cihs fs+ tcms = map mkTCM ts+ tcihs = concatMap tcmTCIH tcms+ in PkgConfig {+ pcfg_classModules = ms+ , pcfg_classImportHeaders = cihs+ , pcfg_topLevelImportHeader = tih+ , pcfg_templateClassModules = tcms+ , pcfg_templateClassImportHeaders = tcihs+ , pcfg_additional_c_incs = acincs+ , pcfg_additional_c_srcs = acsrcs+ }+++-- TODO: change [String] to Set String+mkHSBOOTCandidateList :: [ClassModule] -> [String]+mkHSBOOTCandidateList ms =+ let+ -- get only class dependencies, not template classes.+ cs = rights (concatMap cmImportedModulesHighSource ms)+ in+ nub (map getClassModuleBase cs)++++-- |+mkPkgHeaderFileName ::Class -> HeaderName+mkPkgHeaderFileName c =+ HdrName ( (cabal_cheaderprefix.class_cabal) c+ <> fst (hsClassName c)+ <.> "h"+ )++-- |+mkPkgCppFileName ::Class -> String+mkPkgCppFileName c =+ (cabal_cheaderprefix.class_cabal) c+ <> fst (hsClassName c)+ <.> "cpp"++-- |+mkPkgIncludeHeadersInH :: Class -> [HeaderName]+mkPkgIncludeHeadersInH c =+ let pkgname = (cabal_pkgname . class_cabal) c+ extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c+ extheaders = nub . map ((<>"Type.h") . unCabalName . getPkgName) $ extclasses+ in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders++++-- |+mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]+mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right+++-- |+mkCIH :: (ModuleUnit -> ModuleUnitImports) -- ^ (mk namespace and include headers)+ -> Class+ -> ClassImportHeader+mkCIH getImports c =+ ClassImportHeader {+ cihClass = c+ , cihSelfHeader = mkPkgHeaderFileName c+ , cihNamespace = (muimports_namespaces . getImports . MU_Class . class_name) c+ , cihSelfCpp = mkPkgCppFileName c+ , cihImportedClasses = mkModuleDepCpp (Right c)+ , cihIncludedHPkgHeadersInH = mkPkgIncludeHeadersInH c+ , cihIncludedHPkgHeadersInCPP = mkPkgIncludeHeadersInCPP c+ , cihIncludedCPkgHeaders = (muimports_headers . getImports . MU_Class . class_name) c+ }++-- | for top-level+mkTIH+ :: CabalName+ -> (ModuleUnit -> ModuleUnitImports)+ -> [ClassImportHeader]+ -> [TopLevelFunction]+ -> TopLevelImportHeader+mkTIH pkgname getImports cihs fs =+ let tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs+ tl_cs2 = concatMap (returnDependency . extractClassDepForTopLevelFunction) fs+ tl_cs = nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2)+ -- NOTE: Select only class dependencies in the current package.+ -- TODO: This is clearly not a good impl. we need to look into this again+ -- after reconsidering multi-package generation.+ tl_cihs = catMaybes (foldr fn [] tl_cs)+ where+ fn c ys =+ let y = find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs+ in y:ys+ -- NOTE: The remaining class dependencies outside the current package+ extclasses = filter ((/= pkgname) . getPkgName) tl_cs+ extheaders = map HdrName $+ nub $+ map ((<>"Type.h") . unCabalName . getPkgName) extclasses++ in+ TopLevelImportHeader {+ tihHeaderFileName = unCabalName pkgname <> "TopLevel"+ , tihClassDep = tl_cihs+ , tihExtraClassDep = extclasses+ , tihFuncs = fs+ , tihNamespaces = muimports_namespaces (getImports MU_TopLevel)+ , tihExtraHeadersInH = extheaders+ , tihExtraHeadersInCPP = muimports_headers (getImports MU_TopLevel)+ }
+ lib/FFICXX/Generate/Name.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE RecordWildCards #-}+module FFICXX.Generate.Name where++import Data.Char (toLower)+import Data.Maybe (fromMaybe,maybe)+import Data.Monoid ((<>))+--+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Util++++hsFrontNameForTopLevelFunction :: TopLevelFunction -> String+hsFrontNameForTopLevelFunction tfn =+ let (x:xs) = case tfn of+ TopLevelFunction {..} -> fromMaybe toplevelfunc_name toplevelfunc_alias+ TopLevelVariable {..} -> fromMaybe toplevelvar_name toplevelvar_alias+ in toLower x : xs+++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) caHaskellName (class_alias c)+ in (cname, "Raw" <> cname)++hsClassNameForTArg :: TemplateArgType -> String+hsClassNameForTArg (TArg_Class c) = fst (hsClassName c)+hsClassNameForTArg (TArg_TypeParam p) = p+hsClassNameForTArg (TArg_Other s) = s++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+++ffiClassName :: Class -> String+ffiClassName c = maybe (class_name c) caFFIName (class_alias c)++hscFuncName :: Class -> Function -> String+hscFuncName c f = "c_"+ <> toLowers (ffiClassName c)+ <> "_"+ <> toLowers (aliasedFuncName c f)++hsFuncName :: Class -> Function -> String+hsFuncName c f = let (x:xs) = aliasedFuncName c f+ in (toLower x) : xs++aliasedFuncName :: Class -> Function -> String+aliasedFuncName c f =+ case f of+ Constructor _ a -> fromMaybe (constructorName c) a+ Virtual _ str _ a -> fromMaybe str a+ NonVirtual _ str _ a -> fromMaybe (nonvirtualName c str) a+ Static _ str _ a -> fromMaybe (nonvirtualName c str) a+ Destructor a -> fromMaybe destructorName a+++hsTmplFuncName :: TemplateClass -> TemplateFunction -> String+hsTmplFuncName t f =+ case f of+ TFun {..} -> tfun_name -- TODO: alias+ TFunNew {..} -> fromMaybe ("new"<> tclass_name t) tfun_new_alias+ TFunDelete -> "delete" <> tclass_name t+++hsTmplFuncNameTH :: TemplateClass -> TemplateFunction -> String+hsTmplFuncNameTH t f = "t_" <> hsTmplFuncName t f+++hsTemplateMemberFunctionName :: Class -> TemplateMemberFunction -> String+hsTemplateMemberFunctionName c f = fromMaybe (nonvirtualName c (tmf_name f)) (tmf_alias f)+ -- fst (hsClassName c) <> "_" <> tmf_name f -- TODO: alias+++hsTemplateMemberFunctionNameTH :: Class -> TemplateMemberFunction -> String+hsTemplateMemberFunctionNameTH c f = "t_" <> hsTemplateMemberFunctionName c f+++ffiTmplFuncName :: TemplateFunction -> String+ffiTmplFuncName f =+ case f of+ TFun {..} -> fromMaybe tfun_name tfun_alias+ TFunNew {..} -> fromMaybe "new" tfun_new_alias+ TFunDelete -> "delete"+++cppTmplFuncName :: TemplateFunction -> String+cppTmplFuncName f =+ case f of+ TFun {..} -> tfun_name+ TFunNew {..} -> "new"+ TFunDelete -> "delete"++accessorName :: Class -> Variable -> Accessor -> String+accessorName c v a = nonvirtualName c (var_name v)+ <> "_"+ <> case a of+ Getter -> "get"+ Setter -> "set"++hscAccessorName :: Class -> Variable -> Accessor -> String+hscAccessorName c v a = "c_" <> toLowers (accessorName c v a)+++cppStaticName :: Class -> Function -> String+cppStaticName c f = class_name c <> "::" <> func_name f++cppFuncName :: Class -> Function -> String+cppFuncName c f = case f of+ Constructor _ _ -> "new"+ Virtual _ _ _ _ -> func_name f+ NonVirtual _ _ _ _-> func_name f+ Static _ _ _ _-> cppStaticName c f+ Destructor _ -> destructorName++constructorName :: Class -> String+constructorName c = "new" <> (fst.hsClassName) c++nonvirtualName :: Class -> String -> String+nonvirtualName c str = (firstLower.fst.hsClassName) c <> "_" <> str++destructorName :: String+destructorName = "delete"+
+ lib/FFICXX/Generate/Type/Cabal.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DeriveGeneric #-}++-----------------------------------------------------------------------------+-- |+-- Module : FFICXX.Generate.Type.Cabal+-- Copyright : (c) 2011-2018 Ian-Woo Kim+--+-- License : BSD3+-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.Type.Cabal where++import Data.Aeson (FromJSON(..),ToJSON(..)+ ,genericParseJSON,genericToJSON+ ,defaultOptions)+import Data.Aeson.Types (fieldLabelModifier)+import Data.Text (Text)+import GHC.Generics (Generic)++data AddCInc = AddCInc FilePath String++data AddCSrc = AddCSrc FilePath String++-- TODO: change String to Text+newtype CabalName = CabalName { unCabalName :: String }+ deriving (Show,Eq,Ord)++-- TODO: change String to Text+data Cabal =+ Cabal {+ cabal_pkgname :: CabalName+ , cabal_version :: String+ , cabal_cheaderprefix :: String+ , cabal_moduleprefix :: String+ , cabal_additional_c_incs :: [AddCInc]+ , cabal_additional_c_srcs :: [AddCSrc]+ , cabal_additional_pkgdeps :: [CabalName]+ , cabal_license :: Maybe String+ , cabal_licensefile :: Maybe String+ , cabal_extraincludedirs :: [FilePath]+ , cabal_extralibdirs :: [FilePath]+ , cabal_extrafiles :: [FilePath]+ , cabal_pkg_config_depends :: [String]+ }++data GeneratedCabalInfo =+ GeneratedCabalInfo {+ gci_pkgname :: Text+ , gci_version :: Text+ , gci_synopsis :: Text+ , gci_description :: Text+ , gci_homepage :: Text+ , gci_license :: Text+ , gci_licenseFile :: Text+ , gci_author :: Text+ , gci_maintainer :: Text+ , gci_category :: Text+ , gci_buildtype :: Text+ , gci_extraFiles :: [Text]+ , gci_csrcFiles :: [Text]+ , gci_sourcerepository :: Text+ , gci_ccOptions :: [Text]+ , gci_pkgdeps :: [Text]+ , gci_exposedModules :: [Text]+ , gci_otherModules :: [Text]+ , gci_extraLibDirs :: [Text]+ , gci_extraLibraries :: [Text]+ , gci_extraIncludeDirs :: [Text]+ , gci_pkgconfigDepends :: [Text]+ , gci_includeFiles :: [Text]+ , gci_cppFiles :: [Text]+ }+ deriving (Show,Generic)++instance ToJSON GeneratedCabalInfo where+ toJSON = genericToJSON defaultOptions {fieldLabelModifier = drop 4}++instance FromJSON GeneratedCabalInfo where+ parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = drop 4}
lib/FFICXX/Generate/Type/Class.hs view
@@ -16,21 +16,10 @@ module FFICXX.Generate.Type.Class where -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(..) )-import System.FilePath ---import FFICXX.Generate.Util-import FFICXX.Generate.Util.HaskellSrcExts---- some type aliases-+import FFICXX.Generate.Type.Cabal -- | C types data CTypes = CTString@@ -53,240 +42,40 @@ data CPPTypes = CPTClass Class | CPTClassRef Class | CPTClassCopy Class+ | CPTClassMove Class deriving Show -- | const flag data IsConst = Const | NoConst deriving Show +-- | Argument type which can be used as an template argument like float+-- in vector<float>.+-- For now, this distinguishes Class and non-Class.+data TemplateArgType = TArg_Class Class+ | TArg_TypeParam String+ | TArg_Other String+ deriving Show++data TemplateAppInfo = TemplateAppInfo {+ tapp_tclass :: TemplateClass+ , tapp_tparam :: TemplateArgType+ , tapp_CppTypeForParam :: String+ }+ deriving Show+ data Types = Void | SelfType | CT CTypes IsConst | CPT CPPTypes IsConst- | TemplateApp { tapp_hstemplate :: TemplateClass- , tapp_HaskellTypeForParam :: String- , tapp_CppTypeForParam :: String }- | TemplateAppRef { tappref_hstemplate :: TemplateClass- , tappref_HaskellTypeForParam :: String- , tappref_CppTypeForParam :: String }- | TemplateType TemplateClass- | TemplateParam String+ | TemplateApp TemplateAppInfo -- ^ like vector<float>*+ | TemplateAppRef TemplateAppInfo -- ^ like vector<float>&+ | TemplateAppMove TemplateAppInfo -- ^ like unique_ptr<float> (using std::move)+ | TemplateType TemplateClass -- ^ template self? TODO: clarify this.+ | TemplateParam String+ | TemplateParamPointer String -- ^ this is A* with template<A> deriving Show -cvarToStr :: CTypes -> IsConst -> String -> String-cvarToStr ctyp isconst varname = ctypToStr ctyp isconst <> " " <> varname--ctypToStr :: CTypes -> IsConst -> String-ctypToStr ctyp isconst =- let typword = case ctyp of- CTString -> "char*"- CTChar -> "char"- CTInt -> "int"- CTUInt -> "unsigned int"- CTLong -> "signed long"- CTULong -> "long unsigned int"- CTDouble -> "double"- CTBool -> "int" -- Currently available solution- CTDoubleStar -> "double *"- CTVoidStar -> "void*"- CTIntStar -> "int*"- CTCharStarStar -> "char**"- CPointer s -> ctypToStr s NoConst <> "*"- CRef s -> ctypToStr s NoConst <> "*"- in case isconst of- Const -> "const" <> " " <> typword- NoConst -> typword---self_ :: Types-self_ = SelfType--cstring_ :: Types-cstring_ = CT CTString Const--cint_ :: Types-cint_ = CT CTInt Const--int_ :: Types-int_ = CT CTInt NoConst--uint_ :: Types-uint_ = CT CTUInt NoConst--ulong_ :: Types-ulong_ = CT CTULong NoConst--long_ :: Types-long_ = CT CTLong NoConst--culong_ :: Types-culong_ = CT CTULong Const--clong_ :: Types-clong_ = CT CTLong Const--cchar_ :: Types-cchar_ = CT CTChar Const--char_ :: Types-char_ = CT CTChar NoConst--short_ :: Types-short_ = int_--cdouble_ :: Types-cdouble_ = CT CTDouble Const--double_ :: Types-double_ = CT CTDouble NoConst--doublep_ :: Types-doublep_ = CT CTDoubleStar NoConst--float_ :: Types-float_ = double_--bool_ :: Types-bool_ = CT CTBool NoConst--void_ :: Types-void_ = Void--voidp_ :: Types-voidp_ = CT CTVoidStar NoConst--intp_ :: Types-intp_ = CT CTIntStar NoConst--intref_ :: Types-intref_ = CT (CRef CTInt) NoConst---charpp_ :: Types-charpp_ = CT CTCharStarStar NoConst--ref_ :: CTypes -> Types-ref_ t = CT (CRef t) NoConst--star_ :: CTypes -> Types-star_ t = CT (CPointer t) NoConst--cstar_ :: CTypes -> Types-cstar_ t = CT (CPointer t) Const--self :: String -> (Types, String)-self var = (self_, var)--voidp :: String -> (Types,String)-voidp var = (voidp_ , var)--cstring :: String -> (Types,String)-cstring var = (cstring_ , var)--cint :: String -> (Types,String)-cint var = (cint_ , var)--int :: String -> (Types,String)-int var = (int_ , var)--uint :: String -> (Types,String)-uint var = (uint_ , var)--long :: String -> (Types,String)-long var = (long_, var)--ulong :: String -> (Types,String)-ulong var = (ulong_ , var)--clong :: String -> (Types,String)-clong var = (clong_, var)--culong :: String -> (Types,String)-culong var = (culong_ , var)--cchar :: String -> (Types,String)-cchar var = (cchar_ , var)--char :: String -> (Types,String)-char var = (char_ , var)--short :: String -> (Types,String)-short = int--cdouble :: String -> (Types,String)-cdouble var = (cdouble_ , var)--double :: String -> (Types,String)-double var = (double_ , var)--doublep :: String -> (Types,String)-doublep var = (doublep_ , var)--float :: String -> (Types,String)-float = double--bool :: String -> (Types,String)-bool var = (bool_ , var)--intp :: String -> (Types, String)-intp var = (intp_ , var)--intref :: String -> (Types, String)-intref var = (intref_, var)--charpp :: String -> (Types, String)-charpp var = (charpp_, var)--ref :: CTypes -> String -> (Types,String)-ref t var = (ref_ t, var)--star :: CTypes -> String -> (Types, String)-star t var = (star_ t, var)--cstar :: CTypes -> String -> (Types, String)-cstar t var = (cstar_ t, var)---cppclass_ :: Class -> Types-cppclass_ c = CPT (CPTClass c) NoConst--cppclass :: Class -> String -> (Types, String)-cppclass c vname = ( cppclass_ c, vname)----cppclassconst :: Class -> String -> (Types, String)-cppclassconst c vname = ( CPT (CPTClass c) Const, vname)--cppclassref_ :: Class -> Types-cppclassref_ c = CPT (CPTClassRef c) NoConst--cppclassref :: Class -> String -> (Types, String)-cppclassref c vname = (cppclassref_ c, vname)--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"-hsCTypeName CTInt = "CInt"-hsCTypeName CTUInt = "CUInt"-hsCTypeName CTLong = "CLong"-hsCTypeName CTULong = "CULong"-hsCTypeName CTDouble = "CDouble"-hsCTypeName CTDoubleStar = "(Ptr CDouble)"-hsCTypeName CTBool = "CInt"-hsCTypeName CTVoidStar = "(Ptr ())"-hsCTypeName CTIntStar = "(Ptr CInt)"-hsCTypeName CTCharStarStar = "(Ptr (CString))"-hsCTypeName (CPointer t) = "(Ptr " <> hsCTypeName t <> ")"-hsCTypeName (CRef t) = "(Ptr " <> hsCTypeName t <> ")"- ------------- type Args = [(Types,String)]@@ -313,6 +102,22 @@ deriving Show +data Variable = Variable { var_type :: Types+ , var_name :: String+ }+ deriving Show++data TemplateMemberFunction =+ TemplateMemberFunction {+ tmf_param :: String+ , tmf_ret :: Types+ , tmf_name :: String+ , tmf_args :: Args+ , tmf_alias :: Maybe String+ }+ deriving Show++ data TopLevelFunction = TopLevelFunction { toplevelfunc_ret :: Types , toplevelfunc_name :: String , toplevelfunc_args :: Args@@ -323,16 +128,9 @@ , toplevelvar_alias :: Maybe String } deriving Show -hsFrontNameForTopLevelFunction :: TopLevelFunction -> String-hsFrontNameForTopLevelFunction tfn =- let (x:xs) = case tfn of- TopLevelFunction {..} -> maybe toplevelfunc_name id toplevelfunc_alias- TopLevelVariable {..} -> maybe toplevelvar_name id toplevelvar_alias- in toLower x : xs - isNewFunc :: Function -> Bool isNewFunc (Constructor _ _) = True isNewFunc _ = False@@ -369,171 +167,47 @@ staticFuncs :: [Function] -> [Function] staticFuncs = filter isStaticFunc -argToString :: (Types,String) -> String-argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname-argToString (SelfType, varname) = "Type ## _p " <> varname-argToString (CPT (CPTClass c) isconst, varname) = case isconst of- Const -> "const_" <> cname <> "_p " <> varname- NoConst -> cname <> "_p " <> varname- where cname = class_name c-argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of- Const -> "const_" <> cname <> "_p " <> varname- NoConst -> cname <> "_p " <> varname- where cname = class_name c-argToString (TemplateApp _ _ _,varname) = "void* " <> varname-argToString (TemplateAppRef _ _ _,varname) = "void* " <> varname-argToString _ = error "undefined argToString"--argsToString :: Args -> String-argsToString args =- let args' = (SelfType, "p") : args- in intercalateWith conncomma argToString args'--argsToStringNoSelf :: Args -> String-argsToStringNoSelf = intercalateWith conncomma argToString---argToCallString :: (Types,String) -> String-argToCallString (CT (CRef _) _,varname) = "(*"<> varname<> ")"-argToCallString (CPT (CPTClass c) _,varname) =- "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = class_name c-argToCallString (CPT (CPTClassRef c) _,varname) =- "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c-argToCallString (TemplateApp _ _ cp,varname) =- "to_nonconst<"<>str<>",void>("<>varname<>")" where str = cp-argToCallString (TemplateAppRef _ _ cp,varname) =- "*( ("<> str <> "*) " <>varname<>")" where str = cp -argToCallString (_,varname) = varname--argsToCallString :: Args -> String-argsToCallString = intercalateWith conncomma argToCallString---rettypeToString :: Types -> String-rettypeToString (CT ctyp isconst) = ctypToStr ctyp isconst-rettypeToString Void = "void"-rettypeToString SelfType = "Type ## _p"-rettypeToString (CPT (CPTClass c) _) = class_name c <> "_p"-rettypeToString (CPT (CPTClassRef c) _) = class_name c <> "_p"-rettypeToString (CPT (CPTClassCopy c) _) = class_name c <> "_p"-rettypeToString (TemplateApp _ _ _) = "void*"-rettypeToString (TemplateAppRef _ _ _) = "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 _ (TemplateAppRef _ _ _,_v) = error "tmpArgToString: TemplateAppRef"-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 _ (TemplateAppRef _ _ _) = "void*"-tmplRetTypeToString _ (TemplateType _) = "void*"-tmplRetTypeToString b (TemplateParam _) = if b- then "Type"- else "Type ## _p"--- -------- newtype ProtectedMethod = Protected { unProtected :: [String] }- deriving (Monoid)--data AddCInc = AddCInc FilePath String--data AddCSrc = AddCSrc FilePath String+ deriving (Monoid) -data Cabal = Cabal { cabal_pkgname :: String- , cabal_cheaderprefix :: String- , cabal_moduleprefix :: String- , cabal_additional_c_incs :: [AddCInc]- , cabal_additional_c_srcs :: [AddCSrc]- }--data CabalAttr = CabalAttr { cabalattr_license :: Maybe String- , cabalattr_licensefile :: Maybe String- , cabalattr_extraincludedirs :: [FilePath]- , cabalattr_extralibdirs :: [FilePath]- , cabalattr_extrafiles :: [FilePath]- }--instance Default CabalAttr where- def = CabalAttr { cabalattr_license = Nothing- , cabalattr_licensefile = Nothing- , cabalattr_extraincludedirs = []- , cabalattr_extralibdirs = []- , cabalattr_extrafiles = []- }+data ClassAlias = ClassAlias { caHaskellName :: String+ , caFFIName :: String+ } -data Class = Class { class_cabal :: Cabal- , class_name :: String- , class_parents :: [Class]- , class_protected :: ProtectedMethod- , class_alias :: Maybe String- , class_funcs :: [Function]- }- | AbstractClass { class_cabal :: Cabal- , class_name :: String- , class_parents :: [Class]- , class_protected :: ProtectedMethod- , class_alias :: Maybe String- , class_funcs :: [Function]- }+-- TODO: partial record must be avoided.+data Class = Class {+ class_cabal :: Cabal+ , class_name :: String+ , class_parents :: [Class]+ , class_protected :: ProtectedMethod+ , class_alias :: Maybe ClassAlias+ , class_funcs :: [Function]+ , class_vars :: [Variable]+ , class_tmpl_funcs :: [TemplateMemberFunction]+ }+ | AbstractClass {+ class_cabal :: Cabal+ , class_name :: String+ , class_parents :: [Class]+ , class_protected :: ProtectedMethod+ , class_alias :: Maybe ClassAlias+ , class_funcs :: [Function]+ , class_vars :: [Variable]+ , class_tmpl_funcs :: [TemplateMemberFunction]+ } +-- TODO: we had better not override standard definitions instance Show Class where show x = show (class_name x) +-- TODO: we had better not override standard definitions instance Eq Class where (==) x y = class_name x == class_name y +-- TODO: we had better not override standard definitions instance Ord Class where compare x y = compare (class_name x) (class_name y) @@ -543,24 +217,28 @@ , tfun_oname :: String , tfun_args :: Args , tfun_alias :: Maybe String }- | TFunNew { tfun_new_args :: Args }+ | TFunNew { tfun_new_args :: Args+ , tfun_new_alias :: Maybe String+ } | TFunDelete--- deriving (Show,Eq,Ord) + data TemplateClass = TmplCls { tclass_cabal :: Cabal , tclass_name :: String , tclass_oname :: String , tclass_param :: String , tclass_funcs :: [TemplateFunction] }--- deriving (Show,Eq,Ord) +-- TODO: we had better not override standard definitions instance Show TemplateClass where show x = show (tclass_name x <> " " <> tclass_param x) +-- TODO: we had better not override standard definitions instance Eq TemplateClass where (==) x y = tclass_name x == tclass_name y +-- TODO: we had better not override standard definitions instance Ord TemplateClass where compare x y = compare (tclass_name x) (tclass_name y) @@ -571,9 +249,9 @@ } data Selfness = Self | NoSelf- + -- | Check abstract class isAbstractClass :: Class -> Bool@@ -582,346 +260,7 @@ -- type DaughterMap = M.Map String [Class] -class_allparents :: Class -> [Class]-class_allparents c = let ps = class_parents c- in if null ps- then []- else nub (ps <> (concatMap class_allparents ps))---getClassModuleBase :: Class -> String-getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (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- where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)- in foldl (addmeToYourDaughterList c) m ps- addmeToYourDaughterList c m p = let f Nothing = Just [c]- f (Just cs) = Just (c:cs)- in M.alter f p m------ | Daughter Map including itself as a daughter-mkDaughterSelfMap :: [Class] -> DaughterMap-mkDaughterSelfMap = foldl worker M.empty- where worker m c = let ps = map getClassModuleBase (c:class_allparents c)- in foldl (addToList c) m ps- addToList c m p = let f Nothing = Just [c]- f (Just cs) = Just (c:cs)- in M.alter f p m---- |-ctypToHsTyp :: Maybe Class -> Types -> String-ctypToHsTyp _c Void = "()"-ctypToHsTyp (Just c) SelfType = (fst.hsClassName) c-ctypToHsTyp Nothing SelfType = error "ctypToHsTyp : SelfType but no class "-ctypToHsTyp _c (CT CTString _) = "CString"-ctypToHsTyp _c (CT CTInt _) = "CInt"-ctypToHsTyp _c (CT CTUInt _) = "CUInt"-ctypToHsTyp _c (CT CTChar _) = "CChar"-ctypToHsTyp _c (CT CTLong _) = "CLong"-ctypToHsTyp _c (CT CTULong _) = "CULong"-ctypToHsTyp _c (CT CTDouble _) = "CDouble"-ctypToHsTyp _c (CT CTBool _ ) = "CInt"-ctypToHsTyp _c (CT CTDoubleStar _) = "(Ptr CDouble)"-ctypToHsTyp _c (CT CTVoidStar _) = "(Ptr ())"-ctypToHsTyp _c (CT CTIntStar _) = "(Ptr CInt)"-ctypToHsTyp _c (CT CTCharStarStar _) = "(Ptr CString)"-ctypToHsTyp _c (CT (CPointer t) _) = hsCTypeName (CPointer t)-ctypToHsTyp _c (CT (CRef t) _) = hsCTypeName (CRef t)-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 (TemplateAppRef 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 (TemplateAppRef 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 _ (TemplateAppRef _ _ _ ) = 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)--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---hscFuncName :: Class -> Function -> String-hscFuncName c f = "c_" <> toLowers (class_name c) <> "_" <> toLowers (aliasedFuncName c f)--hsFuncName :: Class -> Function -> String-hsFuncName c f = let (x:xs) = aliasedFuncName c f- in (toLower x) : xs--hsFuncXformer :: Function -> String-hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func)- in if len > 0- then "xform" <> show (len - 1)- else "xformnull"-hsFuncXformer func@(Static _ _ _ _) =- let len = length (genericFuncArgs func)- in if len > 0- then "xform" <> show (len - 1)- else "xformnull"-hsFuncXformer func = let len = length (genericFuncArgs func)- in "xform" <> show len---genericFuncRet :: Function -> Types-genericFuncRet f =- case f of- Constructor _ _ -> self_- Virtual t _ _ _ -> t- NonVirtual t _ _ _-> t- Static t _ _ _ -> t- Destructor _ -> void_--genericFuncArgs :: Function -> Args-genericFuncArgs (Destructor _) = []-genericFuncArgs f = func_args f--aliasedFuncName :: Class -> Function -> String-aliasedFuncName c f =- case f of- Constructor _ a -> maybe (constructorName c) id a- 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- Destructor a -> maybe destructorName id a--cppStaticName :: Class -> Function -> String-cppStaticName c f = class_name c <> "::" <> func_name f--cppFuncName :: Class -> Function -> String-cppFuncName c f = case f of- Constructor _ _ -> "new"- Virtual _ _ _ _ -> func_name f- NonVirtual _ _ _ _-> func_name f- Static _ _ _ _-> cppStaticName c f- Destructor _ -> destructorName--constructorName :: Class -> String-constructorName c = "new" <> (fst.hsClassName) c--nonvirtualName :: Class -> String -> String-nonvirtualName c str = (firstLower.fst.hsClassName) c <> str--destructorName :: String-destructorName = "delete"---classConstraints :: Class -> Context ()-classConstraints = cxTuple . 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))- (TemplateAppRef 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,assts) = extractArgRetTypes (Just c) (isVirtualFunc f) (genericFuncArgs f,genericFuncRet f)- ctxt = cxTuple assts- arg0- | isVirtualFunc f = (mkTVar "a" :)- | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :)- | otherwise = id- in TyForall () Nothing (Just ctxt) (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 :: [Type ()]- argtyps = map (hsargtype . fst) args- rettyp :: Type ()- 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 :: Types -> Type ()- 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 (TemplateAppRef 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 (TemplateAppRef 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-+data Accessor = Getter | Setter+ deriving (Show, Eq)
+ lib/FFICXX/Generate/Type/Config.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE DeriveGeneric #-}+module FFICXX.Generate.Type.Config where++import Data.Hashable (Hashable(..))+import Data.HashMap.Strict (HashMap)+import GHC.Generics (Generic)+--+import FFICXX.Generate.Type.PackageInterface (HeaderName(..),Namespace(..))++data ModuleUnit = MU_TopLevel + | MU_Class String+ deriving (Show,Eq,Generic)++instance Hashable ModuleUnit++data ModuleUnitImports =+ ModuleUnitImports {+ muimports_namespaces :: [Namespace]+ , muimports_headers :: [HeaderName]+ }+ deriving (Show)++emptyModuleUnitImports = ModuleUnitImports [] []++newtype ModuleUnitMap = ModuleUnitMap { unModuleUnitMap :: HashMap ModuleUnit ModuleUnitImports }
lib/FFICXX/Generate/Type/Module.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Module--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,30 +12,35 @@ module FFICXX.Generate.Type.Module where -import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.PackageInterface---newtype Namespace = NS { unNamespace :: String } deriving (Show)+import FFICXX.Generate.Type.Cabal (AddCInc,AddCSrc)+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.PackageInterface (HeaderName(..),Namespace(..)) +-- | C++ side+-- HPkg is generated C++ headers by fficxx, CPkg is original C++ headers data ClassImportHeader = ClassImportHeader { cihClass :: Class , cihSelfHeader :: HeaderName , cihNamespace :: [Namespace] , cihSelfCpp :: String- , cihIncludedHPkgHeadersInH :: [HeaderName]- , cihIncludedHPkgHeadersInCPP :: [HeaderName]- , cihIncludedCPkgHeaders :: [HeaderName]+ , cihImportedClasses :: [Either TemplateClass Class] -- ^ Dependencies TODO: clarify this.+ , cihIncludedHPkgHeadersInH :: [HeaderName] -- TODO: Explain why we need to have these two+ , cihIncludedHPkgHeadersInCPP :: [HeaderName] -- separately.+ , cihIncludedCPkgHeaders :: [HeaderName] } deriving (Show) ++-- | Haskell side data ClassModule = ClassModule { cmModule :: String , cmClass :: [Class] , cmCIH :: [ClassImportHeader]- , cmImportedModulesHighNonSource :: [String]- , cmImportedModulesRaw :: [String]- , cmImportedModulesHighSource :: [String]- , cmImportedModulesForFFI :: [String]+ , cmImportedModulesHighNonSource :: [Either TemplateClass Class] -- ^ imported modules that do not need source+ -- NOTE: source means the same cabal package.+ -- TODO: rename Source to something more clear.+ , cmImportedModulesRaw :: [Either TemplateClass Class] -- ^ imported modules for raw types.+ , cmImportedModulesHighSource :: [Either TemplateClass Class] -- ^ imported modules that need source+ , cmImportedModulesForFFI :: [Either TemplateClass Class] , cmExtraImport :: [String] } deriving (Show) @@ -49,10 +54,17 @@ , tcihSelfHeader :: HeaderName } deriving (Show) -data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String- , tihClassDep :: [ClassImportHeader]- , tihFuncs :: [TopLevelFunction]- } deriving (Show)+data TopLevelImportHeader = TopLevelImportHeader {+ tihHeaderFileName :: String+ , tihClassDep :: [ClassImportHeader]+ , tihExtraClassDep :: [Either TemplateClass Class]+ -- ^ Extra class dependencies outside current package.+ -- NOTE: we cannot fully construct ClassImportHeader for them.+ , tihFuncs :: [TopLevelFunction]+ , tihNamespaces :: [Namespace]+ , tihExtraHeadersInH :: [HeaderName]+ , tihExtraHeadersInCPP :: [HeaderName]+ } deriving (Show) data PackageConfig = PkgConfig { pcfg_classModules :: [ClassModule] , pcfg_classImportHeaders :: [ClassImportHeader]@@ -62,5 +74,3 @@ , pcfg_additional_c_incs :: [AddCInc] , pcfg_additional_c_srcs :: [AddCSrc] }--
lib/FFICXX/Generate/Type/PackageInterface.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.PackageInterface--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -27,6 +27,8 @@ instance IsString HeaderName where fromString = HdrName++newtype Namespace = NS { unNamespace :: String } deriving (Show) type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName
lib/FFICXX/Generate/Util.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Util--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -16,8 +17,9 @@ import Data.Char import Data.List import Data.List.Split-import Data.Monoid ( (<>) )-import Data.Text ( Text )+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text.Template@@ -81,11 +83,17 @@ | otherwise = return "" +-- TODO: deprecate this and use contextT context :: [(Text,String)] -> Context context assocs x = maybe err (T.pack) . lookup x $ assocs where err = error $ "Could not find key: " <> (T.unpack x) - +-- TODO: Rename this to context.+-- TODO: Proper error handling.+contextT :: [(Text,Text)] -> Context+contextT assocs x = fromMaybe err . lookup x $ assocs+ where err = error $ T.unpack ("Could not find key: " <> x)+ subst :: Text -> Context -> String subst t c = TL.unpack (substitute t c)
lib/FFICXX/Generate/Util/HaskellSrcExts.hs view
@@ -2,7 +2,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Util.HaskellSrcExts--- Copyright : (c) 2011-2017 Ian-Woo Kim+-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,8 +14,7 @@ module FFICXX.Generate.Util.HaskellSrcExts where -import Data.List (foldl')-import Data.Maybe+import Data.List (foldl') import Language.Haskell.Exts hiding (unit_tycon) import qualified Language.Haskell.Exts (unit_tycon) @@ -43,12 +42,9 @@ qualConDecl = QualConDecl () -recDecl :: String -> [FieldDecl ()] -> ConDecl () -- [([Name ()],Type ())] -> ConDecl ()+recDecl :: String -> [FieldDecl ()] -> ConDecl () recDecl n rs = RecDecl () (Ident () n) rs --- app :: Exp () -> Exp () -> Exp ()--- app = App ()- app' :: String -> String -> Exp () app' x y = App () (mkVar x) (mkVar y) @@ -57,13 +53,13 @@ lit = Lit () -mkVar :: String -> Exp () +mkVar :: String -> Exp () mkVar = Var () . unqual con :: String -> Exp () con = Con () . unqual -mkTVar :: String -> Type () +mkTVar :: String -> Type () mkTVar = TyVar () . Ident () mkPVar :: String -> Pat ()@@ -113,7 +109,7 @@ #else mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls mderiv #endif- where declhead = mkDeclHead n tbinds + where declhead = mkDeclHead n tbinds mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () #if MIN_VERSION_haskell_src_exts(1,20,0)@@ -143,8 +139,8 @@ ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) where islist = ImportSpecList () False (map mkIVar lst) - -mkImportSrc :: String -> ImportDecl () ++mkImportSrc :: String -> ImportDecl () mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing lang :: [String] -> ModulePragma ()@@ -197,6 +193,8 @@ ethingwith = EThingWith () ethingall q = ethingwith (EWildcard () 0) q []++emodule nm = EModuleContents () (ModuleName () nm) nonamespace = NoNamespace ()
− sample/cxxlib/Makefile
@@ -1,10 +0,0 @@-TARGET = lib/libmysample.so-SOURCES = src/A.cpp src/B.cpp-CPPFLAGS = -Iinclude-CXXFLAGS = -fPIC-LDFLAGS = -shared -Wl,-soname,libmysample.so--objects = $(patsubst %.cpp,%.o,$(SOURCES))-$(TARGET): $(objects)- mkdir -p lib- $(CC) $(LDFLAGS) $(objects) -o $@
− sample/cxxlib/include/A.h
@@ -1,13 +0,0 @@-#ifndef __A__-#define __A__ --class A-{ -public: - A(); - virtual void Foo( void );-- virtual void Foo2( long t );-}; --#endif // __A__
− sample/cxxlib/include/B.h
@@ -1,13 +0,0 @@-#ifndef __B__ -#define __B__--#include "A.h"-class B : public A -{ -public: - B();- virtual void Foo(void); - virtual void Bar(void); -}; --#endif // __B__
− sample/cxxlib/src/A.cpp
@@ -1,16 +0,0 @@-#include <iostream>-#include "A.h"---A::A() { } --void A::Foo() -{ - std::cout << "A:Foo" << std::endl; -} --void A::Foo2( signed long t )-{- std::cout << "A:Foo2 : got " << t << std::endl; -}-
− sample/cxxlib/src/B.cpp
@@ -1,15 +0,0 @@-#include <iostream>-#include "B.h"--B::B() { } --void B::Foo( void ) -{- std::cout << "B:foo" << std::endl; -}--void B::Bar( void ) -{ - std::cout << "bar" << std::endl ; -} -
− sample/mysample-generator/MySampleGen.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--import FFICXX.Generate.Builder-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface--incs = [ AddCInc "test.h" "//test ok?" ]--srcs = [ AddCSrc "test.cpp" "//test ok??" ]---mycabal = Cabal { cabal_pkgname = "MySample"- , cabal_cheaderprefix = "MySample"- , cabal_moduleprefix = "MySample"- , cabal_additional_c_incs = incs- , cabal_additional_c_srcs = srcs- }--mycabalattr = - CabalAttr - { cabalattr_license = Just "BSD3"- , cabalattr_licensefile = Just "LICENSE"- , cabalattr_extraincludedirs = []- , cabalattr_extralibdirs = []- , cabalattr_extrafiles = []- }---myclass = Class mycabal--a :: Class-a = myclass "A" [] mempty Nothing- [ Constructor [] Nothing- , Virtual void_ "method1" [ ] Nothing- ]--b :: Class-b = myclass "B" [a] mempty Nothing- [ Constructor [] Nothing- , Virtual (cppclass_ a) "method2" [ cppclass a "x" ] Nothing- ]--myclasses = [ a, b]--toplevelfunctions = [ ]---main :: IO ()-main = do - simpleBuilder "MySample" [] (mycabal,mycabalattr,myclasses,toplevelfunctions,[]) [ ] []-
− sample/mysample-generator/use_mysample.hs
@@ -1,16 +0,0 @@-import MySample--main :: IO ()-main = do - a <- newA - b <- newB - - foo a - foo b -- foo (upcastA b) -- bar b - - foo2 a 3-
− sample/snappy-generator/SnappyGen.hs
@@ -1,91 +0,0 @@-import Data.Monoid (mempty)----import FFICXX.Generate.Builder-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface--snappyclasses = [ ] --mycabal = Cabal { cabal_pkgname = "Snappy" - , cabal_cheaderprefix = "Snappy"- , cabal_moduleprefix = "Snappy" }---- myclass = Class mycabal ---- this is standard string library-string :: Class -string = - Class mycabal "string" [] mempty (Just "CppString")- [ - ] ---source :: Class -source = - Class mycabal "Source" [] mempty Nothing- [ Virtual ulong_ "Available" [] Nothing - , Virtual (cstar_ CTChar) "Peek" [ star CTULong "len" ] Nothing - , Virtual void_ "Skip" [ ulong "n" ] Nothing- ]---sink :: Class -sink = - Class mycabal "Sink" [] mempty Nothing- [ Virtual void_ "Append" [ cstar CTChar "bytes", ulong "n" ] Nothing - , Virtual (cstar_ CTChar) "GetAppendBuffer" [ ulong "len", star CTChar "scratch" ] Nothing- ] --byteArraySource :: Class-byteArraySource = - Class mycabal "ByteArraySource" [source] mempty Nothing- [ Constructor [ cstar CTChar "p", ulong "n" ] Nothing - ] ---uncheckedByteArraySink :: Class -uncheckedByteArraySink = - Class mycabal "UncheckedByteArraySink" [sink] mempty Nothing- [ Constructor [ star CTChar "dest" ] Nothing - , NonVirtual (star_ CTChar) "CurrentDestination" [] Nothing - ] ---myclasses = [ source, sink, byteArraySource, uncheckedByteArraySink, string ] --toplevelfunctions =- [ TopLevelFunction ulong_ "Compress" [cppclass source "src", cppclass sink "snk"] Nothing - , TopLevelFunction bool_ "GetUncompressedLength" [cppclass source "src", star CTUInt "result"] Nothing - , TopLevelFunction ulong_ "Compress" [cstring "input", ulong "input_length", cppclass string "output"] (Just "compress_1")- , TopLevelFunction bool_ "Uncompress" [cstring "compressed", ulong "compressed_length", cppclass string "uncompressed"] Nothing - , TopLevelFunction void_ "RawCompress" [cstring "input", ulong "input_length", star CTChar "compresseed", star CTULong "compressed_length" ] Nothing- , TopLevelFunction bool_ "RawUncompress" [cstring "compressed", ulong "compressed_length", star CTChar "uncompressed"] Nothing - , TopLevelFunction bool_ "RawUncompress" [cppclass source "src", star CTChar "uncompressed"] (Just "rawUncompress_1")- , TopLevelFunction ulong_ "MaxCompressedLength" [ ulong "source_bytes" ] Nothing- , TopLevelFunction bool_ "GetUncompressedLength" [ cstar CTChar "compressed", ulong "compressed_length", star CTULong "result" ] (Just "getUncompressedLength_1")- , TopLevelFunction bool_ "IsValidCompressedBuffer" [ cstar CTChar "compressed", ulong "compressed_length" ] Nothing - ] ----headerMap = [ ("Sink" , ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))- , ("Source", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))- , ("ByteArraySource", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))- , ("UncheckedByteArraySink", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))- ]--mycabalattr = - CabalAttr - { cabalattr_license = Just "BSD3"- , cabalattr_licensefile = Just "LICENSE"- , cabalattr_extraincludedirs = []- , cabalattr_extralibdirs = []- , cabalattr_extrafiles = []- }--main :: IO ()-main = do - simpleBuilder "Snappy" headerMap (mycabal,mycabalattr,myclasses,toplevelfunctions,[]) [ "snappy" ] []--
− sample/snappy-generator/testSnappy.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--import Control.Applicative ((<$>),(<*>),pure)-import Control.Monad (when)-import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Unsafe as BU---import Foreign.C-import Foreign.Marshal.Alloc-import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable as S--import System.Environment --import Snappy ---main :: IO ()-main = do - putStrLn "test Snappy"-- args <- getArgs- when (length args /= 1) $ do - error "./testSnappy [filename]"- bstr <- B.readFile (head args)-- (obstr,len) <- BU.unsafeUseAsCString bstr $ \cstr -> do - p_ostr <- mallocArray 1000 - p_len <- malloc :: IO (Ptr CULong)- ------------------------------ rawCompress cstr 1000 p_ostr p_len- ------------------------------ len <- S.peek p_len - putStrLn $ "compressed size = " ++ (show len)- (,) <$> BU.unsafePackCString p_ostr <*> pure len - - rstr <- BU.unsafeUseAsCString obstr $ \cstr -> do - p_ostr <- mallocArray 10000- --------------------- b <- rawUncompress cstr len p_ostr- --------------------- putStrLn $ "success? " ++ show b - BU.unsafePackCString p_ostr -- B.putStrLn rstr - - return ()--