diff --git a/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -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 diff --git a/lib/FFICXX/Generate/Builder.hs b/lib/FFICXX/Generate/Builder.hs --- a/lib/FFICXX/Generate/Builder.hs +++ b/lib/FFICXX/Generate/Builder.hs @@ -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 @@ -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 (workingDircabalFileName) + putStrLn "Generating Cabal file" + buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDircabalFileName) -- - putStrLn "header file generation" - let typmacro = TypMcro ("__" <> macrofy (cabal_pkgname cabal) <> "__") + putStrLn "Generating JSON file" + buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDirjsonFileName) + -- + 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 () - diff --git a/lib/FFICXX/Generate/Code/Cabal.hs b/lib/FFICXX/Generate/Code/Cabal.hs --- a/lib/FFICXX/Generate/Code/Cabal.hs +++ b/lib/FFICXX/Generate/Code/Cabal.hs @@ -1,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 @@ -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) diff --git a/lib/FFICXX/Generate/Code/Cpp.hs b/lib/FFICXX/Generate/Code/Cpp.hs --- a/lib/FFICXX/Generate/Code/Cpp.hs +++ b/lib/FFICXX/Generate/Code/Cpp.hs @@ -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 @@ -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 *)" + <> 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(r));" + TemplateAppRef (TemplateAppInfo _ _ cpptype) -> + cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); " + <> "return (static_cast(r));" + TemplateAppMove (TemplateAppInfo _ _ cpptype) -> + cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); " + <> "return std::move(static_cast(r));" + TemplateType _ -> error "returnCpp: TemplateType" + TemplateParam _ -> + if b then "return (" <> callstr <> ");" + else "return to_nonconst((Type *)&(" + <> callstr <> ")) ;" + TemplateParamPointer _ -> + if b then "return (" <> callstr <> ");" + else "return to_nonconst(" + <> 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(newp);" + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | isDeleteFunc func = + let declstr = funcToDecl c func + returnstr = "delete (to_nonconst(p)) ; " + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | isStaticFunc func = + let declstr = funcToDecl c func + callstr = cppFuncName c func <> "(" + <> argsToCallString (genericFuncArgs func) + <> ")" + returnstr = returnCpp False (genericFuncRet func) callstr + in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] + | otherwise = + let declstr = funcToDecl c func + callstr = "to_nonconst(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 <> "*>(p))->" + <> tfun_oname <> "(" + <> tmplAllArgsToCallString b tfun_args + <> ")" + TFunNew {..} -> "new " <> tclass_oname <> "(" + <> tmplAllArgsToCallString b tfun_new_args + <> ")" + TFunDelete -> "delete (static_cast<" <> tclass_oname <> "*>(p))" + returnstr = + case f of + TFunNew {..} -> "return static_cast("<>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(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 + <> "" + <> "(" <> tmplAllArgsToCallString False (tmf_args f) <> ")" + returnstr = returnCpp False (tmf_ret f) callstr diff --git a/lib/FFICXX/Generate/Code/Dependency.hs b/lib/FFICXX/Generate/Code/Dependency.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/Dependency.hs +++ /dev/null @@ -1,266 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Code.Dependency --- Copyright : (c) 2011-2017 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- 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) diff --git a/lib/FFICXX/Generate/Code/HsCast.hs b/lib/FFICXX/Generate/Code/HsCast.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/HsCast.hs @@ -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 + diff --git a/lib/FFICXX/Generate/Code/HsFFI.hs b/lib/FFICXX/Generate/Code/HsFFI.hs --- a/lib/FFICXX/Generate/Code/HsFFI.hs +++ b/lib/FFICXX/Generate/Code/HsFFI.hs @@ -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 @@ -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) diff --git a/lib/FFICXX/Generate/Code/HsFrontEnd.hs b/lib/FFICXX/Generate/Code/HsFrontEnd.hs --- a/lib/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/lib/FFICXX/Generate/Code/HsFrontEnd.hs @@ -1,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 @@ -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 diff --git a/lib/FFICXX/Generate/Code/HsTemplate.hs b/lib/FFICXX/Generate/Code/HsTemplate.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/HsTemplate.hs @@ -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") + ] diff --git a/lib/FFICXX/Generate/Code/MethodDef.hs b/lib/FFICXX/Generate/Code/MethodDef.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/MethodDef.hs +++ /dev/null @@ -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 --- 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 *)" - <> 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 *)&(" - <> 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(newp);" - in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] - | isDeleteFunc func = - let declstr = funcToDecl c func - returnstr = "delete (to_nonconst(p)) ; " - in intercalateWith connBSlash id [declstr, "{", returnstr, "}"] - | isStaticFunc func = - let declstr = funcToDecl c func - callstr = cppFuncName c func <> "(" - <> argsToCallString (genericFuncArgs func) - <> ")" - returnstr = 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 <> "*>(p))->" - <> tfun_oname <> "(" - <> tmplAllArgsToCallString tfun_args - <> ")" - TFunNew {..} -> "new " <> tclass_oname <> "(" - <> tmplAllArgsToCallString tfun_new_args - <> ")" - TFunDelete -> "delete (reinterpret_cast<" <> tclass_oname <> "*>(p))" - - returnstr = - case f of - TFunNew {..} -> "return reinterpret_cast("<>callstr<>");" - TFunDelete -> callstr <> ";" - TFun {..} -> returnCpp b (tfun_ret) callstr - - - - diff --git a/lib/FFICXX/Generate/Code/Primitive.hs b/lib/FFICXX/Generate/Code/Primitive.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Code/Primitive.hs @@ -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 *)" <> 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(r));" + TemplateAppRef _ -> error "castCpp2C: TemplateAppRef" + -- g <> "* r = new " <> g <> "(" <> e <> "); " + -- <> "return (static_cast(r));" + TemplateAppMove _ -> error "castCpp2C: TemplateAppMove" + TemplateType _ -> error "castCpp2C: TemplateType" + TemplateParam _ -> error "castCpp2C: TemplateParam" + -- if b then e + -- else "to_nonconst((Type *)&(" <> e <> "))" + TemplateParamPointer _ -> error "castCpp2C: TemplateParamPointer" + -- if b then "(" <> callstr <> ");" + -- else "to_nonconst(" <> 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) <> "*>(" <> 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) <> "*>(" <> 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) <> "*>(" <> varname <> ")))" + _ -> -- TODO: Implement this. + error "tmplArgToCallString: TemplateAppMove" +tmplArgToCallString b (TemplateParam _,varname) = + case b of + True -> varname + False -> "*(to_nonconst(" <> varname <> "))" +tmplArgToCallString b (TemplateParamPointer _,varname) = + case b of + True -> varname + False -> "to_nonconst(" <> 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 diff --git a/lib/FFICXX/Generate/ContentMaker.hs b/lib/FFICXX/Generate/ContentMaker.hs --- a/lib/FFICXX/Generate/ContentMaker.hs +++ b/lib/FFICXX/Generate/ContentMaker.hs @@ -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 @@ -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 \n\ + "#include\n\ \$header\n\ \\n\ \$namespace\n\ \\n\ - \#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n\ - \\n\ - \#define TYPECASTMETHOD(cname,mname,oname) \\\n\ - \ IIF( CHECKPROTECT(cname,mname) ) ( \\\n\ - \ (to_nonconst), \\\n\ - \ (to_nonconst) )\n\ + \$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) diff --git a/lib/FFICXX/Generate/Dependency.hs b/lib/FFICXX/Generate/Dependency.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Dependency.hs @@ -0,0 +1,430 @@ +{-# LANGUAGE RecordWildCards #-} +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Dependency +-- Copyright : (c) 2011-2018 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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) + } diff --git a/lib/FFICXX/Generate/Name.hs b/lib/FFICXX/Generate/Name.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Name.hs @@ -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" + diff --git a/lib/FFICXX/Generate/Type/Cabal.hs b/lib/FFICXX/Generate/Type/Cabal.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Type/Cabal.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DeriveGeneric #-} + +----------------------------------------------------------------------------- +-- | +-- Module : FFICXX.Generate.Type.Cabal +-- Copyright : (c) 2011-2018 Ian-Woo Kim +-- +-- License : BSD3 +-- Maintainer : Ian-Woo Kim +-- 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} diff --git a/lib/FFICXX/Generate/Type/Class.hs b/lib/FFICXX/Generate/Type/Class.hs --- a/lib/FFICXX/Generate/Type/Class.hs +++ b/lib/FFICXX/Generate/Type/Class.hs @@ -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. +-- 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* + | TemplateAppRef TemplateAppInfo -- ^ like vector& + | TemplateAppMove TemplateAppInfo -- ^ like unique_ptr (using std::move) + | TemplateType TemplateClass -- ^ template self? TODO: clarify this. + | TemplateParam String + | TemplateParamPointer String -- ^ this is A* with template 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) diff --git a/lib/FFICXX/Generate/Type/Config.hs b/lib/FFICXX/Generate/Type/Config.hs new file mode 100644 --- /dev/null +++ b/lib/FFICXX/Generate/Type/Config.hs @@ -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 } diff --git a/lib/FFICXX/Generate/Type/Module.hs b/lib/FFICXX/Generate/Type/Module.hs --- a/lib/FFICXX/Generate/Type/Module.hs +++ b/lib/FFICXX/Generate/Type/Module.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.Module --- Copyright : (c) 2011-2016 Ian-Woo Kim +-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -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] } - - diff --git a/lib/FFICXX/Generate/Type/PackageInterface.hs b/lib/FFICXX/Generate/Type/PackageInterface.hs --- a/lib/FFICXX/Generate/Type/PackageInterface.hs +++ b/lib/FFICXX/Generate/Type/PackageInterface.hs @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Type.PackageInterface --- Copyright : (c) 2011-2016 Ian-Woo Kim +-- Copyright : (c) 2011-2018 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim @@ -27,6 +27,8 @@ instance IsString HeaderName where fromString = HdrName + +newtype Namespace = NS { unNamespace :: String } deriving (Show) type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName diff --git a/lib/FFICXX/Generate/Util.hs b/lib/FFICXX/Generate/Util.hs --- a/lib/FFICXX/Generate/Util.hs +++ b/lib/FFICXX/Generate/Util.hs @@ -1,7 +1,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 @@ -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) diff --git a/lib/FFICXX/Generate/Util/HaskellSrcExts.hs b/lib/FFICXX/Generate/Util/HaskellSrcExts.hs --- a/lib/FFICXX/Generate/Util/HaskellSrcExts.hs +++ b/lib/FFICXX/Generate/Util/HaskellSrcExts.hs @@ -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 @@ -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 () diff --git a/sample/cxxlib/Makefile b/sample/cxxlib/Makefile deleted file mode 100644 --- a/sample/cxxlib/Makefile +++ /dev/null @@ -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 $@ diff --git a/sample/cxxlib/include/A.h b/sample/cxxlib/include/A.h deleted file mode 100644 --- a/sample/cxxlib/include/A.h +++ /dev/null @@ -1,13 +0,0 @@ -#ifndef __A__ -#define __A__ - -class A -{ -public: - A(); - virtual void Foo( void ); - - virtual void Foo2( long t ); -}; - -#endif // __A__ diff --git a/sample/cxxlib/include/B.h b/sample/cxxlib/include/B.h deleted file mode 100644 --- a/sample/cxxlib/include/B.h +++ /dev/null @@ -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__ diff --git a/sample/cxxlib/src/A.cpp b/sample/cxxlib/src/A.cpp deleted file mode 100644 --- a/sample/cxxlib/src/A.cpp +++ /dev/null @@ -1,16 +0,0 @@ -#include -#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; -} - diff --git a/sample/cxxlib/src/B.cpp b/sample/cxxlib/src/B.cpp deleted file mode 100644 --- a/sample/cxxlib/src/B.cpp +++ /dev/null @@ -1,15 +0,0 @@ -#include -#include "B.h" - -B::B() { } - -void B::Foo( void ) -{ - std::cout << "B:foo" << std::endl; -} - -void B::Bar( void ) -{ - std::cout << "bar" << std::endl ; -} - diff --git a/sample/mysample-generator/MySampleGen.hs b/sample/mysample-generator/MySampleGen.hs deleted file mode 100644 --- a/sample/mysample-generator/MySampleGen.hs +++ /dev/null @@ -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,[]) [ ] [] - diff --git a/sample/mysample-generator/use_mysample.hs b/sample/mysample-generator/use_mysample.hs deleted file mode 100644 --- a/sample/mysample-generator/use_mysample.hs +++ /dev/null @@ -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 - diff --git a/sample/snappy-generator/SnappyGen.hs b/sample/snappy-generator/SnappyGen.hs deleted file mode 100644 --- a/sample/snappy-generator/SnappyGen.hs +++ /dev/null @@ -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" ] [] - - diff --git a/sample/snappy-generator/testSnappy.hs b/sample/snappy-generator/testSnappy.hs deleted file mode 100644 --- a/sample/snappy-generator/testSnappy.hs +++ /dev/null @@ -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 () - -