diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-2013, Ian-Woo Kim. All rights reserved. +Copyright 2011-2019, Ian-Woo Kim. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,10 +0,0 @@ -#! /usr/bin/env runhaskell - -> import Distribution.Simple -> import Distribution.PackageDescription -> --import System.Process -> main = defaultMain -> --main = defaultMainWithHooks testUserHooks -> --testUserHooks = simpleUserHooks { -> -- preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo -> -- } diff --git a/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -1,21 +1,22 @@ Name: fficxx -Version: 0.5.1 -Synopsis: automatic C++ binding generation -Description: automatic C++ binding generation +Version: 0.6 +Synopsis: Automatic C++ binding generation +Description: fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++. License: BSD3 License-file: LICENSE Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Build-Type: Simple Category: FFI Tools -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Source-repository head type: git location: http://www.github.com/wavewave/fficxx Library - hs-source-dirs: lib + hs-source-dirs: src + default-language: Haskell2010 Build-Depends: base == 4.* , aeson , aeson-pretty @@ -26,6 +27,7 @@ , directory , either , errors + , fficxx-runtime , filepath>1 , hashable , haskell-src-exts >= 1.18 @@ -39,33 +41,30 @@ , template-haskell , text , unordered-containers - - Exposed-Modules: - FFICXX.Generate.Builder - FFICXX.Generate.Config - 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.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 + FFICXX.Generate.Builder + FFICXX.Generate.Config + FFICXX.Generate.Code.Cpp + FFICXX.Generate.Code.HsCast + FFICXX.Generate.Code.HsFFI + FFICXX.Generate.Code.HsFrontEnd + FFICXX.Generate.Code.HsProxy + FFICXX.Generate.Code.HsTemplate + FFICXX.Generate.Code.Cabal + 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 diff --git a/lib/FFICXX/Generate/Builder.hs b/lib/FFICXX/Generate/Builder.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Builder.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Builder --- Copyright : (c) 2011-2019 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Builder where - -import Control.Monad ( void, when ) -import qualified Data.ByteString.Lazy.Char8 as L -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 - , createDirectoryIfMissing - , doesFileExist - ) -import System.IO ( hPutStrLn, withFile, IOMode(..) ) -import System.Process ( readProcess ) --- -import FFICXX.Generate.Code.Cabal -import FFICXX.Generate.Dependency -import FFICXX.Generate.Config ( FFICXXConfig(..) - , SimpleBuilderConfig(..) - ) -import FFICXX.Generate.ContentMaker -import FFICXX.Generate.Type.Cabal ( Cabal(..) - , CabalName(..) - , AddCInc(..) - , AddCSrc(..) - ) -import FFICXX.Generate.Type.Module -import FFICXX.Generate.Type.PackageInterface -import FFICXX.Generate.Util --- - -macrofy :: String -> String -macrofy = map ((\x->if x=='-' then '_' else x) . toUpper) - - -simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO () -simpleBuilder cfg sbc = do - putStrLn "----------------------------------------------------" - putStrLn "-- fficxx code generation for Haskell-C++ binding --" - putStrLn "----------------------------------------------------" - let SimpleBuilderConfig - topLevelMod - mumap - cabal - classes - toplevelfunctions - templates - extralibs - extramods - staticFiles - = sbc - pkgname = cabal_pkgname cabal - putStrLn ("Generating " <> unCabalName pkgname) - let workingDir = fficxxconfig_workingDir cfg - installDir = fficxxconfig_installBaseDir cfg - staticDir = fficxxconfig_staticFileDir cfg - - pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) = - mkPackageConfig - (pkgname, findModuleUnitImports mumap) - (classes, toplevelfunctions,templates,extramods) - (cabal_additional_c_incs cabal) - (cabal_additional_c_srcs cabal) - hsbootlst = mkHSBOOTCandidateList mods - cabalFileName = unCabalName pkgname <.> "cabal" - jsonFileName = unCabalName pkgname <.> "json" - -- - createDirectoryIfMissing True workingDir - createDirectoryIfMissing True installDir - createDirectoryIfMissing True (installDir "src") - createDirectoryIfMissing True (installDir "csrc") - -- - putStrLn "Copying static files" - mapM_ (\x->copyFileWithMD5Check (staticDir x) (installDir x)) staticFiles - -- - putStrLn "Generating Cabal file" - buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDircabalFileName) - -- - 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 (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 for_ tcihs $ \tcih -> - let t = tcihTClass tcih - hdr = unHdrName (tcihSelfHeader tcih) - in gen hdr (buildTemplateHeader typmacro t) - -- - putStrLn "Generating Cpp file" - for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) - gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih) - -- - 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 "Generating RawType.hs" - for_ mods $ \m -> gen - (cmModule m <.> "RawType" <.> "hs") - (prettyPrint (buildRawTypeHs m)) - -- - putStrLn "Generating FFI.hsc" - for_ mods $ \m -> gen - (cmModule m <.> "FFI" <.> "hsc") - (prettyPrint (buildFFIHsc m)) - -- - putStrLn "Generating Interface.hs" - for_ mods $ \m -> gen - (cmModule m <.> "Interface" <.> "hs") - (prettyPrint (buildInterfaceHs mempty m)) - -- - putStrLn "Generating Cast.hs" - for_ mods $ \m -> gen - (cmModule m <.> "Cast" <.> "hs") - (prettyPrint (buildCastHs m)) - -- - 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)) - - -- - -- 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 "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) (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] "") - - -copyFileWithMD5Check :: FilePath -> FilePath -> IO () -copyFileWithMD5Check src tgt = do - b <- doesFileExist tgt - if b - then do - srcmd5 <- md5 <$> L.readFile src - tgtmd5 <- md5 <$> L.readFile tgt - if srcmd5 == tgtmd5 then return () else copyFile src tgt - else copyFile src tgt - - -copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO () -copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs acincs acsrcs) = do - let thfile = cprefix <> "Type.h" - tlhfile = tihHeaderFileName tih <.> "h" - tlcppfile = tihHeaderFileName tih <.> "cpp" - copyFileWithMD5Check (wdir thfile) (ddir thfile) - doesFileExist (wdir tlhfile) - >>= flip when (copyFileWithMD5Check (wdir tlhfile) (ddir tlhfile)) - doesFileExist (wdir tlcppfile) - >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) - for_ cihs $ \header-> do - let hfile = unHdrName (cihSelfHeader header) - cppfile = cihSelfCpp header - copyFileWithMD5Check (wdir hfile) (ddir hfile) - copyFileWithMD5Check (wdir cppfile) (ddir cppfile) - - for_ tcihs $ \header-> do - let hfile = unHdrName (tcihSelfHeader header) - copyFileWithMD5Check (wdir hfile) (ddir hfile) - - for_ acincs $ \(AddCInc header _) -> - copyFileWithMD5Check (wdir header) (ddir header) - - for_ acsrcs $ \(AddCSrc csrc _) -> - copyFileWithMD5Check (wdir csrc) (ddir csrc) - - -moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO () -moduleFileCopy wdir ddir fname = do - let (fnamebody,fnameext) = splitExtension fname - (mdir,mfile) = moduleDirFile fnamebody - origfpath = wdir fname - (mfile',_mext') = splitExtension mfile - newfpath = ddir mdir mfile' <> fnameext - b <- doesFileExist origfpath - when b $ do - createDirectoryIfMissing True (ddir mdir) - copyFileWithMD5Check origfpath newfpath - - -copyModule :: FilePath -> FilePath -> ClassModule -> IO () -copyModule wdir ddir m = do - let modbase = cmModule m - moduleFileCopy wdir ddir $ modbase <> ".hs" - moduleFileCopy wdir ddir $ modbase <> ".RawType.hs" - moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc" - moduleFileCopy wdir ddir $ modbase <> ".Interface.hs" - moduleFileCopy wdir ddir $ modbase <> ".Cast.hs" - moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs" - moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot" - - -copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO () -copyTemplateModule wdir ddir m = do - let modbase = tcmModule m - moduleFileCopy wdir ddir $ modbase <> ".Template.hs" - moduleFileCopy wdir ddir $ modbase <> ".TH.hs" diff --git a/lib/FFICXX/Generate/Code/Cabal.hs b/lib/FFICXX/Generate/Code/Cabal.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/Cabal.hs +++ /dev/null @@ -1,291 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Code.Cabal --- Copyright : (c) 2011-2019 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Code.Cabal where - -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.Cabal ( AddCInc(..) - , AddCSrc(..) - , BuildType(..) - , CabalName(..) - , Cabal(..) - , GeneratedCabalInfo(..) - ) -import FFICXX.Generate.Type.Module -import FFICXX.Generate.Type.PackageInterface -import FFICXX.Generate.Util - - -cabalIndentation :: Text -cabalIndentation = T.replicate 23 " " - - -unlinesWithIndent = T.unlines . map (cabalIndentation <>) - --- for source distribution -genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) - -> [AddCInc] - -> [AddCSrc] - -> [String] -genCsrcFiles (tih,cmods) acincs acsrcs = - let -- indent = cabalIndentation - selfheaders' = do - x <- cmods - y <- cmCIH x - return (cihSelfHeader y) - selfheaders = nub selfheaders' - selfcpp' = do - x <- cmods - y <- cmCIH x - return (cihSelfCpp y) - selfcpp = nub selfcpp' - tlh = tihHeaderFileName tih <.> "h" - tlcpp = tihHeaderFileName tih <.> "cpp" - includeFileStrsWithCsrc = map (\x->"csrc" x) $ - (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders)) - ++ map (\(AddCInc hdr _) -> hdr) acincs - cppFilesWithCsrc = map (\x->"csrc"x) $ - (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) - ++ map (\(AddCSrc src _) -> src) acsrcs - - - in includeFileStrsWithCsrc <> cppFilesWithCsrc - --- for library -genIncludeFiles :: String -- ^ package name - -> ([ClassImportHeader],[TemplateClassImportHeader]) - -> [AddCInc] - -> [String] -genIncludeFiles pkgname (cih,tcih) acincs = - let -- indent = cabalIndentation - selfheaders = map cihSelfHeader cih <> map tcihSelfHeader tcih - 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 - x <- cmods - y <- cmCIH x - return (cihSelfCpp y) - selfcpp = nub selfcpp' - tlcpp = tihHeaderFileName tih <.> "cpp" - cppFileStrs = map (\x -> "csrc" x) $ - (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) - ++ map (\(AddCSrc src _) -> src) acsrcs - in cppFileStrs - - - --- | 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 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 = - "Name: $pkgname\n\ - \Version: $version\n\ - \Synopsis: $synopsis\n\ - \Description: $description\n\ - \Homepage: $homepage\n\ - \$licenseField\n\ - \$licenseFileField\n\ - \Author: $author\n\ - \Maintainer: $maintainer\n\ - \Category: $category\n\ - \Tested-with: GHC >= 7.6\n\ - \$buildtype\n\ - \cabal-version: >= 2\n\ - \Extra-source-files:\n\ - \$extraFiles\n\ - \$csrcFiles\n\ - \\n\ - \$sourcerepository\n\ - \\n\ - \Library\n\ - \ default-language: Haskell2010\n\ - \ hs-source-dirs: src\n\ - \ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\ - \ ghc-prof-options: -caf-all -auto-all\n\ - \ cxx-options: $cxxOptions\n\ - \ Build-Depends: $pkgdeps\n\ - \ Exposed-Modules:\n\ - \$exposedModules\n\ - \ Other-Modules:\n\ - \$otherModules\n\ - \ extra-lib-dirs: $extralibdirs\n\ - \ extra-libraries: $extraLibraries\n\ - \ Include-dirs: csrc $extraincludedirs\n\ - \ pkgconfig-depends: $pkgconfigDepends\n\ - \ Install-includes:\n\ - \$includeFiles\n\ - \ C-sources:\n\ - \$cppFiles\n" - - - --- 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 = 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 = case cabal_buildType cabal of - Simple -> - "Build-Type: Simple" - Custom deps -> - "Build-Type: Custom\ncustom-setup\n setup-depends: " - <> T.pack (intercalate ", " (map unCabalName deps)) - <> "\n" - , gci_extraFiles = map T.pack extrafiles - , gci_csrcFiles = map T.pack $ genCsrcFiles (tih,classmodules) acincs acsrcs - , gci_sourcerepository = "" - , gci_cxxOptions = ["-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) - , ("cxxOptions" , T.intercalate " " gci_cxxOptions) - , ("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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/Cpp.hs +++ /dev/null @@ -1,490 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Code.Cpp --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Code.Cpp where - -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 --- - ----- ----- Declaration ----- - ----- "Class Type Declaration" Instances - -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", ffiClassName c) ]) - - ----- "Class Declaration Virtual" Declaration - -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 (ffiClassName aclass) ) - , ("funcdecl" , funcDeclStr ) ]) - - ----- "Class Declaration Non-Virtual" Declaration - -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) - . class_funcs $ c - in declBodyStr - - ----- "Class Declaration Accessor" Declaration - -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 - - ----- "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 - -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 - - ----- "Class Definition NonVirtual" Declaration - -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 - - ----- 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 = - subst "${capitalclassname}_DEF_NONVIRT(${classname})" - (context [ ("capitalclassname", toUppers (ffiClassName c)) - , ("classname" , ffiClassName c ) ]) - -genCppDefInstAccessor :: Class -> String -genCppDefInstAccessor c = - subst "${capitalclassname}_DEF_ACCESSOR(${classname})" - (context [ ("capitalclassname", toUppers (ffiClassName c)) - , ("classname" , ffiClassName c ) ]) - ------------------ - -genAllCppHeaderInclude :: ClassImportHeader -> String -genAllCppHeaderInclude header = - intercalateWith connRet (\x->"#include \""<>x<>"\"") $ - map unHdrName (cihIncludedHPkgHeadersInCPP header - <> cihIncludedCPkgHeaders header) - ----- - - - -------------------------- --- TOP LEVEL FUNCTIONS -- -------------------------- - -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 {..} = - subst "$returntype $funcname ( );" - (context [ ("returntype", rettypeToString toplevelvar_ret ) - , ("funcname" , "TopLevel_" - <> maybe toplevelvar_name id toplevelvar_alias) ]) - -genTopLevelFuncCppDefinition :: TopLevelFunction -> String -genTopLevelFuncCppDefinition TopLevelFunction {..} = - let tmpl = "$returntype $funcname ( $args ) { \n $funcbody\n}" - callstr = toplevelfunc_name <> "(" - <> argsToCallString toplevelfunc_args - <> ")" - funcDefStr = returnCpp False (toplevelfunc_ret) callstr - in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret ) - , ("funcname" , "TopLevel_" - <> maybe toplevelfunc_name id toplevelfunc_alias) - , ("args" , argsToStringNoSelf toplevelfunc_args ) - , ("funcbody" , funcDefStr ) ]) -genTopLevelFuncCppDefinition TopLevelVariable {..} = - let tmpl = "$returntype $funcname ( ) { \n $funcbody\n}" - callstr = toplevelvar_name - funcDefStr = returnCpp False (toplevelvar_ret) callstr - in subst tmpl (context [ ("returntype", rettypeToString toplevelvar_ret ) - , ("funcname" , "TopLevel_" - <> maybe toplevelvar_name id toplevelvar_alias) - , ("funcbody" , funcDefStr ) ]) - - -genTmplFunCpp :: Bool -- ^ is for simple type? - -> TemplateClass - -> TemplateFunction - -> String -genTmplFunCpp b t@TmplCls {..} f = subst tmpl ctxt - where - tmpl = "#define ${tname}_${fname}${suffix}(Type) \\\n\ - \ extern \"C\" { \\\n\ - \ $decl; \\\n\ - \ } \\\n\ - \ inline $defn \\\n\ - \ auto a_${tname}_${fname}_ ## Type = ${tname}_${fname}_ ## Type ;\n" - ctxt = context $ - (("suffix",if b then "_s" else ""):) $ - [ ("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 -genTmplClassCpp b TmplCls {..} fs = subst tmpl ctxt - where - tmpl = "#define ${tname}_instance${suffix}(Type) \\\n\ - \$macro\n" - suffix = if b then "_s" else "" - ctxt = context [ ("tname" , tclass_name ) - , ("suffix" , suffix ) - , ("macro" , macro ) ] - tname = tclass_name - macro1 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 = "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 {..} 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/HsCast.hs b/lib/FFICXX/Generate/Code/HsCast.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/HsCast.hs +++ /dev/null @@ -1,37 +0,0 @@ -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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/HsFFI.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Code.HsFFI --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Code.HsFFI where - -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 - -- 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 - then Nothing - else let hfile = unHdrName headerfilename - -- 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)) 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 -- ----------------------------- - -genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl () -genTopLevelFuncFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ - where (fname,args,ret) = - case tfn of - TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) - TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) - hfilename = tihHeaderFileName header <.> "h" - -- TODO: This must be exposed as a top-level function - cfname = "c_" <> toLowers fname - typ =hsFFIFuncTyp Nothing (CFunSig args ret) diff --git a/lib/FFICXX/Generate/Code/HsFrontEnd.hs b/lib/FFICXX/Generate/Code/HsFrontEnd.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/HsFrontEnd.hs +++ /dev/null @@ -1,334 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Code.HsFrontEnd --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Code.HsFrontEnd where - -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 - ,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 - let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body - sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) - body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c - return cdecl - -------------------- - -genHsFrontInst :: Class -> Class -> [Decl ()] -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 - 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 - -> Reader AnnotateMap [Decl ()] -genHsFrontInstNew c = do - -- amap <- ask - let fs = filter isNewFunc (class_funcs c) - return . flip concatMap fs $ \f -> - let - -- for the time being, let's ignore annotation. - -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap - -- newfuncann = mkComment 0 cann - rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing - -genHsFrontInstNonVirtual :: Class -> [Decl ()] -genHsFrontInstNonVirtual c = - flip concatMap nonvirtualFuncs $ \f -> - let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing - where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) - ------ - -genHsFrontInstStatic :: Class -> [Decl ()] -genHsFrontInstStatic c = - flip concatMap (staticFuncs (class_funcs c)) $ \f -> - let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) - in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing - ------ - -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 - - - - --------------------------- - -hsClassRawType :: Class -> [Decl ()] -hsClassRawType c = - [ mkData rawname [] [] Nothing - , mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv - , mkInstance cxEmpty "FPtr" [hightype] - [ insType (tyapp (tycon "Raw") hightype) rawtype - , 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 - rawtype = tycon rawname - 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")) - - ------------- --- upcast -- ------------- - -genHsFrontUpcastClass :: Class -> [Decl ()] -genHsFrontUpcastClass c = mkFun ("upcast"<>highname) typ [mkPVar "h"] rhs Nothing - where (highname,rawname) = hsClassName c - hightype = tycon highname - rawtype = tycon rawname - iname = typeclassName c - a_bind = unkindedVar (name "a") - a_tvar = mkTVar "a" - typ = tyForall (Just [a_bind]) - (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]])) - (tyfun a_tvar hightype) - rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing - , pbind (mkPVarSig "fh2" (tyapp tyPtr rawtype)) - (app (mkVar "castPtr") (mkVar "fh")) Nothing - ] - (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") - - --------------- --- downcast -- --------------- - -genHsFrontDowncastClass :: Class -> [Decl ()] -genHsFrontDowncastClass c = mkFun ("downcast"<>highname) typ [mkPVar "h"] rhs Nothing - where (highname,_rawname) = hsClassName c - hightype = tycon highname - iname = typeclassName c - a_bind = unkindedVar (name "a") - a_tvar = mkTVar "a" - typ = tyForall (Just [a_bind]) - (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]])) - (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") - - ------------------------- --- Top Level Function -- ------------------------- - - -genTopLevelFuncDef :: TopLevelFunction -> [Decl ()] -genTopLevelFuncDef f@TopLevelFunction {..} = - let fname = hsFrontNameForTopLevelFunction f - 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 - rhs = app (mkVar xformerstr) (mkVar cfname) - - in mkFun fname sig [] rhs Nothing -genTopLevelFuncDef v@TopLevelVariable {..} = - let fname = hsFrontNameForTopLevelFunction v - 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 - - ------------- --- Export -- ------------- - -genExport :: Class -> [ExportSpec ()] -genExport c = - let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) - then eabs nonamespace (unqual n) - else ethingall (unqual n) - 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 - --- | 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 - <> nonVirtualNotNewFuncs fs) - --- | staic function export list -genExportStatic :: Class -> [ExportSpec ()] -genExportStatic c = map (evar . unqual) fns - where fs = class_funcs c - fns = map (aliasedFuncName c) (staticFuncs fs) - - ------------- --- Import -- ------------- - -genExtraImport :: ClassModule -> [ImportDecl ()] -genExtraImport cm = map mkImport (cmExtraImport cm) - - -genImportInModule :: [Class] -> [ImportDecl ()] -genImportInModule = concatMap (\x -> map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"]) - - - -genImportInInterface :: ClassModule -> [ImportDecl ()] -genImportInInterface m = - let modlstraw = cmImportedModulesRaw m - modlstparent = cmImportedModulesHighNonSource m - modlsthigh = cmImportedModulesHighSource m - in [mkImport (cmModule m <.> "RawType")] - <> 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 = - let modlstraw' = cmImportedModulesForFFI m - 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 (\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 - - --- | 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 - --- | 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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/HsTemplate.hs +++ /dev/null @@ -1,180 +0,0 @@ -{-# 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/Primitive.hs b/lib/FFICXX/Generate/Code/Primitive.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Code/Primitive.hs +++ /dev/null @@ -1,882 +0,0 @@ -{-# 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 - CTBool -> "bool" - CTChar -> "char" - CTClock -> "clock_t" - CTDouble -> "double" - CTFile -> "FILE" - CTFloat -> "float" - CTFpos -> "fpos_t" - CTInt -> "int" - CTIntMax -> "intmax_t" - CTIntPtr -> "intptr_t" - CTJmpBuf -> "jmp_buf" - CTLLong -> "long long" - CTLong -> "long" - CTPtrdiff -> "ptrdiff_t" - CTSChar -> "sized char" - CTSUSeconds -> "suseconds_t" - CTShort -> "short" - CTSigAtomic -> "sig_atomic_t" - CTSize -> "size_t" - CTTime -> "time_t" - CTUChar -> "unsigned char" - CTUInt -> "unsigned int" - CTUIntMax -> "uintmax_t" - CTUIntPtr -> "uintptr_t" - CTULLong -> "unsigned long long" - CTULong -> "unsigned long" - CTUSeconds -> "useconds_t" - CTUShort -> "unsigned short" - CTWchar -> "wchar_t" - CTInt8 -> "int8_t" - CTInt16 -> "int16_t" - CTInt32 -> "int32_t" - CTInt64 -> "int64_t" - CTUInt8 -> "uint8_t" - CTUInt16 -> "uint16_t" - CTUInt32 -> "uint32_t" - CTUInt64 -> "uint64_t" - CTString -> "char*" - CTVoidStar -> "void*" - CEnum _ type_str -> type_str - 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 - -cshort_ :: Types -cshort_ = CT CTShort Const - -short_ :: Types -short_ = CT CTShort NoConst - -cdouble_ :: Types -cdouble_ = CT CTDouble Const - -double_ :: Types -double_ = CT CTDouble NoConst - -doublep_ :: Types -doublep_ = CT (CPointer CTDouble) NoConst - -cfloat_ :: Types -cfloat_ = CT CTFloat Const - -float_ :: Types -float_ = CT CTFloat NoConst - -bool_ :: Types -bool_ = CT CTBool NoConst - -void_ :: Types -void_ = Void - -voidp_ :: Types -voidp_ = CT CTVoidStar NoConst - -intp_ :: Types -intp_ = CT (CPointer CTInt) NoConst - -intref_ :: Types -intref_ = CT (CRef CTInt) NoConst - - -charpp_ :: Types -charpp_ = CT (CPointer CTString) 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) - -cshort :: String -> (Types,String) -cshort var = (cshort_ , var) - -short :: String -> (Types,String) -short var = (short_ , var) - -cdouble :: String -> (Types,String) -cdouble var = (cdouble_ , var) - -double :: String -> (Types,String) -double var = (double_ , var) - -doublep :: String -> (Types,String) -doublep var = (doublep_ , var) - -cfloat :: String -> (Types,String) -cfloat var = (float_ , var) - -float :: String -> (Types,String) -float var = (float_ , var) - -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 CTBool = tycon "CBool" -convertC2HS CTChar = tycon "CChar" -convertC2HS CTClock = tycon "CClock" -convertC2HS CTDouble = tycon "CDouble" -convertC2HS CTFile = tycon "CFile" -convertC2HS CTFloat = tycon "CFloat" -convertC2HS CTFpos = tycon "CFpos" -convertC2HS CTInt = tycon "CInt" -convertC2HS CTIntMax = tycon "CIntMax" -convertC2HS CTIntPtr = tycon "CIntPtr" -convertC2HS CTJmpBuf = tycon "CJmpBuf" -convertC2HS CTLLong = tycon "CLLong" -convertC2HS CTLong = tycon "CLong" -convertC2HS CTPtrdiff = tycon "CPtrdiff" -convertC2HS CTSChar = tycon "CSChar" -convertC2HS CTSUSeconds = tycon "CSUSeconds" -convertC2HS CTShort = tycon "CShort" -convertC2HS CTSigAtomic = tycon "CSigAtomic" -convertC2HS CTSize = tycon "CSize" -convertC2HS CTTime = tycon "CTime" -convertC2HS CTUChar = tycon "CUChar" -convertC2HS CTUInt = tycon "CUInt" -convertC2HS CTUIntMax = tycon "CUIntMax" -convertC2HS CTUIntPtr = tycon "CUIntPtr" -convertC2HS CTULLong = tycon "CULLong" -convertC2HS CTULong = tycon "CULong" -convertC2HS CTUSeconds = tycon "CUSeconds" -convertC2HS CTUShort = tycon "CUShort" -convertC2HS CTWchar = tycon "CWchar" -convertC2HS CTInt8 = tycon "Int8" -convertC2HS CTInt16 = tycon "Int16" -convertC2HS CTInt32 = tycon "Int32" -convertC2HS CTInt64 = tycon "Int64" -convertC2HS CTUInt8 = tycon "Word8" -convertC2HS CTUInt16 = tycon "Word16" -convertC2HS CTUInt32 = tycon "Word32" -convertC2HS CTUInt64 = tycon "Word64" -convertC2HS CTString = tycon "CString" -convertC2HS CTVoidStar = tyapp (tycon "Ptr") unit_tycon -convertC2HS (CEnum t _) = convertC2HS t -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/Config.hs b/lib/FFICXX/Generate/Config.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Config.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Config --- Copyright : (c) 2011-2019 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - - -module FFICXX.Generate.Config where - -import FFICXX.Generate.Type.Cabal ( Cabal ) -import FFICXX.Generate.Type.Class ( Class, TemplateClass, TopLevelFunction ) -import FFICXX.Generate.Type.Config ( ModuleUnitMap(..) ) -import FFICXX.Generate.Type.PackageInterface ( HeaderName ) - - -data FFICXXConfig = FFICXXConfig { - fficxxconfig_workingDir :: FilePath - , fficxxconfig_installBaseDir :: FilePath - , fficxxconfig_staticFileDir :: FilePath - } deriving Show - -data SimpleBuilderConfig = - SimpleBuilderConfig { - sbcTopModule :: String - , sbcModUnitMap :: ModuleUnitMap - , sbcCabal :: Cabal - , sbcClasses :: [Class] - , sbcTopLevels :: [TopLevelFunction] - , sbcTemplates :: [(TemplateClass,HeaderName)] - , sbcExtraLibs :: [String] - , sbcExtraDeps :: [(String,[String])] - , sbcStaticFiles :: [String] - } diff --git a/lib/FFICXX/Generate/ContentMaker.hs b/lib/FFICXX/Generate/ContentMaker.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/ContentMaker.hs +++ /dev/null @@ -1,485 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.ContentMaker --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.ContentMaker where - -import Control.Lens ((&),(.~),at) -import Control.Monad.Trans.Reader -import Data.Char (toUpper) -import Data.Either (rights) -import Data.Function (on) -import qualified Data.Map as M -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 System.FilePath --- -import FFICXX.Generate.Code.Cpp -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 (ClassName(..),HeaderName(..) - ,Namespace(..) - ,PackageInterface,PackageName(..) - ,TypeMacro(..)) -import FFICXX.Generate.Util -import FFICXX.Generate.Util.HaskellSrcExts --- - - -srcDir :: FilePath -> FilePath -srcDir installbasedir = installbasedir "src" - -csrcDir :: FilePath -> FilePath -csrcDir installbasedir = installbasedir "csrc" - ----- common function for daughter - --- | -mkGlobal :: [Class] -> ClassGlobal -mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap - - --- | -buildDaughterDef :: ((String,[Class]) -> String) - -> DaughterMap - -> String -buildDaughterDef f m = - let lst = M.toList m - f' (x,xs) = f (x,filter (not.isAbstractClass) xs) - in (concatMap f' lst) - --- | -buildParentDef :: ((Class,Class)->String) -> Class -> String -buildParentDef f cls = g (class_allparents cls,cls) - where g (ps,c) = concatMap (\p -> f (p,c)) ps - --- | -mkProtectedFunctionList :: Class -> String -mkProtectedFunctionList c = - (unlines - . map (\x->"#define IS_" <> class_name c <> "_" <> x <> "_PROTECTED ()") - . unProtected . class_protected) c - --- | -buildTypeDeclHeader :: TypeMacro -- ^ typemacro - -> [Class] - -> String -buildTypeDeclHeader (TypMcro typemacro) classes = - let typeDeclBodyStr = intercalateWith connRet2 (genCppHeaderMacroType) classes - in subst - "#ifdef __cplusplus\n\ - \extern \"C\" { \n\ - \#endif\n\ - \\n\ - \#ifndef $typemacro\n\ - \#define $typemacro\n\ - \\n\ - \$typeDeclBody\n\ - \\n\ - \#endif // $typemacro\n\ - \\n\ - \#ifdef __cplusplus\n\ - \}\n\ - \#endif\n" - (context [ ("typeDeclBody", typeDeclBodyStr ) - , ("typemacro" , typemacro ) ]) - - - -declarationTemplate :: Text -declarationTemplate = - "#ifdef __cplusplus\n\ - \extern \"C\" { \n\ - \#endif\n\ - \\n\ - \#ifndef $typemacro\n\ - \#define $typemacro\n\ - \\n\ - \#include \"${cprefix}Type.h\"\n\ - \ // \n\ - \$declarationheader\n\ - \ // \n\ - \$declarationbody\n\ - \\n\ - \#endif // $typemacro\n\ - \\n\ - \#ifdef __cplusplus\n\ - \}\n\ - \#endif\n" - --- | -buildDeclHeader :: TypeMacro -- ^ typemacro prefix - -> String -- ^ C prefix - -> ClassImportHeader - -> String -buildDeclHeader (TypMcro typemacroprefix) cprefix header = - let classes = [cihClass header] - aclass = cihClass header - typemacrostr = typemacroprefix <> ffiClassName aclass <> "__" - declHeaderStr = intercalateWith - connRet - (\x->"#include \""<>x<>"\"") - (map unHdrName (cihIncludedHPkgHeadersInH header)) - declDefStr = intercalateWith connRet2 genCppHeaderMacroVirtual classes - `connRet2` - intercalateWith connRet genCppHeaderMacroNonVirtual classes - `connRet2` - 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` - intercalateWith connRet genCppHeaderInstNonVirtual classes - `connRet2` - intercalateWith connRet genCppHeaderInstAccessor classes - else "" - declBodyStr = declDefStr - `connRet2` - classDeclsStr - in subst declarationTemplate - (context [ ("typemacro" , typemacrostr ) - , ("cprefix" , cprefix ) - , ("declarationheader", declHeaderStr ) - , ("declarationbody" , declBodyStr ) ]) - - -definitionTemplate :: Text -definitionTemplate = - "#include\n\ - \$header\n\ - \\n\ - \$namespace\n\ - \\n\ - \$alias\n\ - \\n\ - \#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n\ - \\n\ - \#define TYPECASTMETHOD(cname,mname,oname) \\\n\ - \ IIF( CHECKPROTECT(cname,mname) ) ( \\\n\ - \ (to_nonconst), \\\n\ - \ (to_nonconst) )\n\ - \\n\ - \$cppbody\n" - - --- | -buildDefMain :: ClassImportHeader - -> String -buildDefMain 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 cih) - `connRet` - if isAbstractClass aclass - then "" - else genCppDefInstVirtual (aclass, aclass) - `connRet` - intercalateWith connRet genCppDefInstNonVirtual classes - `connRet` - intercalateWith connRet genCppDefInstAccessor classes - in subst definitionTemplate (context ([ ("header" , headerStr ) - , ("alias" , aliasStr ) - , ("namespace", namespaceStr ) - , ("cppbody" , cppBody ) ])) - --- | -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 ) ]) - --- | -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` - 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 - -> TemplateClass - -> String -buildTemplateHeader (TypMcro typemacroprefix) t = - let typemacrostr = typemacroprefix <> "TEMPLATE__" <> map toUpper (tclass_name t) <> "__" - fs = tclass_funcs t - deffunc = intercalateWith connRet (genTmplFunCpp False t) fs - ++ "\n\n" - ++ intercalateWith connRet (genTmplFunCpp True t) fs - classlevel = genTmplClassCpp False t fs ++ "\n\n" ++ genTmplClassCpp True t fs - in subst - "#ifndef $typemacro\n\ - \#define $typemacro\n\ - \\n\ - \$deffunc\n\ - \$classlevel\n\ - \#endif\n" - (context [ ("typemacro", typemacrostr ) - , ("deffunc" , deffunc ) - , ("classlevel" , classlevel ) - ]) - - --- | -buildFFIHsc :: ClassModule -> Module () -buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody - where mname = cmModule m - headers = cmCIH m - ffiImports = [ mkImport "Data.Word" - , mkImport "Data.Int" - , mkImport "Foreign.C" - , mkImport "Foreign.Ptr" - , mkImport (mname <.> "RawType") ] - <> genImportInFFI m - <> genExtraImport m - hscBody = concatMap genHsFFI headers - - --- | -buildRawTypeHs :: ClassModule -> Module () -buildRawTypeHs m = mkModule (cmModule m <.> "RawType") - [lang [ "ForeignFunctionInterface", "TypeFamilies", "MultiParamTypeClasses" - , "FlexibleInstances", "TypeSynonymInstances" - , "EmptyDataDecls", "ExistentialQuantification", "ScopedTypeVariables" ]] - rawtypeImports rawtypeBody - where rawtypeImports = [ mkImport "Foreign.Ptr" - , mkImport "FFICXX.Runtime.Cast" - ] - rawtypeBody = concatMap hsClassRawType . filter (not.isAbstractClass) . cmClass $ m - --- | -buildInterfaceHs :: AnnotateMap -> ClassModule -> Module () -buildInterfaceHs amap m = mkModule (cmModule m <.> "Interface") - [lang [ "EmptyDataDecls", "ExistentialQuantification" - , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface" - , "MultiParamTypeClasses" - , "ScopedTypeVariables" - , "TypeFamilies", "TypeSynonymInstances" - ]] - ifaceImports ifaceBody - where classes = cmClass m - ifaceImports = [ mkImport "Data.Word" - , mkImport "Data.Int" - , mkImport "Foreign.C" - , mkImport "Foreign.Ptr" - , mkImport "FFICXX.Runtime.Cast" ] - <> genImportInInterface m - <> genExtraImport m - ifaceBody = - runReader (mapM genHsFrontDecl classes) amap - <> (concatMap genHsFrontUpcastClass . filter (not.isAbstractClass)) classes - <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes - --- | -buildCastHs :: ClassModule -> Module () -buildCastHs m = mkModule (cmModule m <.> "Cast") - [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies" - , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ] - castImports body - where classes = cmClass m - castImports = [ mkImport "Foreign.Ptr" - , mkImport "FFICXX.Runtime.Cast" - , mkImport "System.IO.Unsafe" ] - <> genImportInCast m - body = mapMaybe genHsFrontInstCastable classes - <> mapMaybe genHsFrontInstCastableSelf classes - --- | -buildImplementationHs :: AnnotateMap -> ClassModule -> Module () -buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation") - [ lang [ "EmptyDataDecls" - , "FlexibleContexts" - , "FlexibleInstances" - , "ForeignFunctionInterface" - , "IncoherentInstances" - , "MultiParamTypeClasses" - , "OverlappingInstances" - , "TemplateHaskell" - , "TypeFamilies" - , "TypeSynonymInstances" - ] ] - implImports implBody - where classes = cmClass m - implImports = [ mkImport "Data.Monoid" -- for template member - , mkImport "Data.Word" - , mkImport "Data.Int" - , mkImport "Foreign.C" - , mkImport "Foreign.Ptr" - , 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 - <> 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") - [lang [ "EmptyDataDecls", "FlexibleInstances", "MultiParamTypeClasses" - , "TypeFamilies"] ] - [ mkImport "Foreign.C.Types" - , mkImport "Foreign.Ptr" - , mkImport "FFICXX.Runtime.Cast" - ] - body - where ts = tcmTemplateClasses m - body = concatMap genTmplInterface ts - -buildTHHs :: TemplateClassModule -> Module () -buildTHHs m = mkModule (tcmModule m <.> "TH") - [lang ["TemplateHaskell"] ] - ([ mkImport "Data.Char" - , mkImport "Data.Monoid" - , mkImport "Foreign.C.Types" - , mkImport "Foreign.Ptr" - , mkImport "Language.Haskell.TH" - , mkImport "Language.Haskell.TH.Syntax" - , mkImport "FFICXX.Runtime.TH" - ] <> imports) - body - where ts = tcmTemplateClasses m - imports = [ mkImport (tcmModule m <.> "Template") ] - body = concatMap genTmplImplementation ts - <> concatMap (\t -> genTmplInstance t (tclass_funcs t)) ts - --- | -buildInterfaceHSBOOT :: String -> Module () -buildInterfaceHSBOOT mname = mkModule (mname <.> "Interface") [] [] hsbootBody - where cname = last (splitOn "." mname) - hsbootBody = [ mkClass cxEmpty ('I':cname) [mkTBind "a"] [] ] - --- | -buildModuleHs :: ClassModule -> Module () -buildModuleHs m = mkModuleE (cmModule m) [] (concatMap genExport (cmClass m)) (genImportInModule (cmClass m)) [] - --- | -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] - -> PackageInterface -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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Dependency.hs +++ /dev/null @@ -1,430 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Name.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# 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/QQ/Verbatim.hs b/lib/FFICXX/Generate/QQ/Verbatim.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/QQ/Verbatim.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.QQ.Verbatim --- Copyright : (c) 2011-2013 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.QQ.Verbatim where - -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Lib - -verbatim :: QuasiQuoter -verbatim = QuasiQuoter{ quoteExp = litE . stringL - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - -- , quotePat = litP . stringP - } - diff --git a/lib/FFICXX/Generate/Type/Annotate.hs b/lib/FFICXX/Generate/Type/Annotate.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Type/Annotate.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Type.Annotate --- Copyright : (c) 2011-2013 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Type.Annotate where - -import qualified Data.Map as M - -data PkgType = PkgModule | PkgClass | PkgMethod - deriving (Show,Eq,Ord) - -type AnnotateMap = M.Map (PkgType,String) String - - - diff --git a/lib/FFICXX/Generate/Type/Cabal.hs b/lib/FFICXX/Generate/Type/Cabal.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Type/Cabal.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Type.Cabal --- Copyright : (c) 2011-2019 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) - - -data BuildType = Simple - | Custom [CabalName] -- ^ dependencies - --- 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] - , cabal_buildType :: BuildType - } - -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_cxxOptions :: [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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Type/Class.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RecordWildCards #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Type.Class --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Type.Class where -import qualified Data.Map as M -import Data.Monoid (Monoid(..)) -import Data.Semigroup (Semigroup(..),(<>)) --- -import FFICXX.Generate.Type.Cabal - - --- | C types -data CTypes = CTBool - | CTChar - | CTClock - | CTDouble - | CTFile - | CTFloat - | CTFpos - | CTInt - | CTIntMax - | CTIntPtr - | CTJmpBuf - | CTLLong - | CTLong - | CTPtrdiff - | CTSChar - | CTSUSeconds - | CTShort - | CTSigAtomic - | CTSize - | CTTime - | CTUChar - | CTUInt - | CTUIntMax - | CTUIntPtr - | CTULLong - | CTULong - | CTUSeconds - | CTUShort - | CTWchar - | CTInt8 - | CTInt16 - | CTInt32 - | CTInt64 - | CTUInt8 - | CTUInt16 - | CTUInt32 - | CTUInt64 - | CTVoidStar - | CTString - | CEnum CTypes String - | CPointer CTypes - | CRef CTypes - deriving Show - --- | C++ types -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 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 - -------------- - -type Args = [(Types,String)] - -data Function = Constructor { func_args :: Args - , func_alias :: Maybe String - } - | Virtual { func_ret :: Types - , func_name :: String - , func_args :: Args - , func_alias :: Maybe String - } - | NonVirtual { func_ret :: Types - , func_name :: String - , func_args :: Args - , func_alias :: Maybe String - } - | Static { func_ret :: Types - , func_name :: String - , func_args :: Args - , func_alias :: Maybe String - } - | Destructor { func_alias :: Maybe String } - 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 - , toplevelfunc_alias :: Maybe String - } - | TopLevelVariable { toplevelvar_ret :: Types - , toplevelvar_name :: String - , toplevelvar_alias :: Maybe String } - deriving Show - - - - -isNewFunc :: Function -> Bool -isNewFunc (Constructor _ _) = True -isNewFunc _ = False - -isDeleteFunc :: Function -> Bool -isDeleteFunc (Destructor _) = True -isDeleteFunc _ = False - -isVirtualFunc :: Function -> Bool -isVirtualFunc (Destructor _) = True -isVirtualFunc (Virtual _ _ _ _) = True -isVirtualFunc _ = False - -isNonVirtualFunc :: Function -> Bool -isNonVirtualFunc (NonVirtual _ _ _ _) = True -isNonVirtualFunc _ = False - - - -isStaticFunc :: Function -> Bool -isStaticFunc (Static _ _ _ _) = True -isStaticFunc _ = False - -virtualFuncs :: [Function] -> [Function] -virtualFuncs = filter isVirtualFunc - -constructorFuncs :: [Function] -> [Function] -constructorFuncs = filter isNewFunc - -nonVirtualNotNewFuncs :: [Function] -> [Function] -nonVirtualNotNewFuncs = - filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x ) - -staticFuncs :: [Function] -> [Function] -staticFuncs = filter isStaticFunc - --------- - -newtype ProtectedMethod = Protected { unProtected :: [String] } - deriving (Semigroup, Monoid) - -data ClassAlias = ClassAlias { caHaskellName :: String - , caFFIName :: String - } - --- 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) - - -data TemplateFunction = TFun { tfun_ret :: Types - , tfun_name :: String - , tfun_oname :: String - , tfun_args :: Args - , tfun_alias :: Maybe String } - | TFunNew { tfun_new_args :: Args - , tfun_new_alias :: Maybe String - } - | TFunDelete - - -data TemplateClass = TmplCls { tclass_cabal :: Cabal - , tclass_name :: String - , tclass_oname :: String - , tclass_param :: String - , tclass_funcs :: [TemplateFunction] - } - --- 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) - - -data ClassGlobal = ClassGlobal - { cgDaughterSelfMap :: DaughterMap - , cgDaughterMap :: DaughterMap - } - -data Selfness = Self | NoSelf - - - --- | Check abstract class - -isAbstractClass :: Class -> Bool -isAbstractClass Class{} = False -isAbstractClass AbstractClass{} = True - - - -type DaughterMap = M.Map String [Class] - -data Accessor = Getter | Setter - deriving (Show, Eq) diff --git a/lib/FFICXX/Generate/Type/Config.hs b/lib/FFICXX/Generate/Type/Config.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Type/Config.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Type/Module.hs +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Type.Module --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Type.Module where - -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 - , 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 :: [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) - -data TemplateClassModule = TCM { tcmModule :: String - , tcmTemplateClasses :: [TemplateClass] - , tcmTCIH :: [TemplateClassImportHeader] - } deriving (Show) - - -data TemplateClassImportHeader = TCIH { tcihTClass :: TemplateClass - , tcihSelfHeader :: HeaderName - } deriving (Show) - -data TopLevelImportHeader = TopLevelImportHeader { - tihHeaderFileName :: String - , tihClassDep :: [ClassImportHeader] - , 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] - , pcfg_topLevelImportHeader :: TopLevelImportHeader - , pcfg_templateClassModules :: [TemplateClassModule] - , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader] - , 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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Type/PackageInterface.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Type.PackageInterface --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - -module FFICXX.Generate.Type.PackageInterface where - -import Data.Hashable -import qualified Data.HashMap.Strict as HM -import Data.String - -newtype PackageName = PkgName String deriving (Hashable, Show, Eq, Ord) -newtype ClassName = ClsName String deriving (Hashable, Show, Eq, Ord) - -newtype HeaderName = HdrName { unHdrName :: String } - deriving (Hashable, Show, Eq, Ord) - - -instance IsString HeaderName where - fromString = HdrName - -newtype Namespace = NS { unNamespace :: String } deriving (Show) - -type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName - -newtype TypeMacro = TypMcro { unTypMcro :: String } - deriving (Show,Eq,Ord) diff --git a/lib/FFICXX/Generate/Util.hs b/lib/FFICXX/Generate/Util.hs deleted file mode 100644 --- a/lib/FFICXX/Generate/Util.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Util --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - - -module FFICXX.Generate.Util where - -import Data.Char -import Data.List -import Data.List.Split -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 - - -moduleDirFile :: String -> (String,String) -moduleDirFile mname = - let splitted = splitOn "." mname - moddir = intercalate "/" (init splitted ) - modfile = (last splitted) <> ".hs" - in (moddir, modfile) - -hline :: IO () -hline = putStrLn "--------------------------------------------------------" - -toUppers :: String -> String -toUppers = map toUpper - -toLowers :: String -> String -toLowers = map toLower - - -firstLower :: String -> String -firstLower [] = [] -firstLower (x:xs) = (toLower x) : xs - -conn :: String -> String -> String -> String -conn st x y = x <> st <> y - -connspace :: String -> String -> String -connspace = conn " " - -conncomma :: String -> String -> String -conncomma = conn ", " - -connBSlash :: String -> String -> String -connBSlash = conn "\\\n" - -connSemicolonBSlash :: String -> String -> String -connSemicolonBSlash = conn "; \\\n" - -connRet :: String -> String -> String -connRet = conn "\n" - -connRet2 :: String -> String -> String -connRet2 = conn "\n\n" - -connArrow :: String -> String -> String -connArrow = conn " -> " - -intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String -intercalateWith f mapper x - | not (null x) = foldl1 f (map mapper x) - | otherwise = "" - - -intercalateWithM :: (Monad m) => (String -> String -> String) -> (a->m String) -> [a] -> m String -intercalateWithM f mapper x - | not (null x) = do ms <- mapM mapper x - return (foldl1 f ms) - | 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 deleted file mode 100644 --- a/lib/FFICXX/Generate/Util/HaskellSrcExts.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- Module : FFICXX.Generate.Util.HaskellSrcExts --- Copyright : (c) 2011-2018 Ian-Woo Kim --- --- License : BSD3 --- Maintainer : Ian-Woo Kim --- Stability : experimental --- Portability : GHC --- ------------------------------------------------------------------------------ - - -module FFICXX.Generate.Util.HaskellSrcExts where - -import Data.Maybe (maybeToList) -import Data.List (foldl') -import Language.Haskell.Exts hiding (unit_tycon) -import qualified Language.Haskell.Exts (unit_tycon) - - -unqual :: String -> QName () -unqual = UnQual () . Ident () - -tycon :: String -> Type () -tycon = TyCon () . unqual - -tyapp :: Type () -> Type () -> Type () -tyapp = TyApp () - -tyfun :: Type () -> Type () -> Type () -tyfun = TyFun () - -tylist :: Type () -> Type () -tylist = TyList () - -unit_tycon :: Type () -unit_tycon = Language.Haskell.Exts.unit_tycon () - -conDecl :: String -> [Type ()] -> ConDecl () -conDecl n ys = ConDecl () (Ident () n) ys - -qualConDecl = QualConDecl () - -recDecl :: String -> [FieldDecl ()] -> ConDecl () -recDecl n rs = RecDecl () (Ident () n) rs - -app' :: String -> String -> Exp () -app' x y = App () (mkVar x) (mkVar y) - - -lit :: Literal () -> Exp () -lit = Lit () - - -mkVar :: String -> Exp () -mkVar = Var () . unqual - -con :: String -> Exp () -con = Con () . unqual - -mkTVar :: String -> Type () -mkTVar = TyVar () . Ident () - -mkPVar :: String -> Pat () -mkPVar = PVar () . Ident () - -mkIVar :: String -> ImportSpec () -mkIVar = IVar () . Ident () - -mkPVarSig :: String -> Type () -> Pat () -mkPVarSig n typ = PatTypeSig () (mkPVar n) typ - -pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl () -pbind pat e = PatBind () pat (UnGuardedRhs () e) - -mkTBind :: String -> TyVarBind () -mkTBind = UnkindedVar () . Ident () - -mkBind1 :: String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl () -mkBind1 n pat rhs mbinds = - FunBind () [ Match () (Ident () n) pat (UnGuardedRhs () rhs) mbinds ] - -mkFun :: String -> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()] -mkFun fname typ pats rhs mbinds = [mkFunSig fname typ, mkBind1 fname pats rhs mbinds] - -mkFunSig :: String -> Type () -> Decl () -mkFunSig fname typ = TypeSig () [Ident () fname] typ - -mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl () -mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just cdecls) - - -dhead :: String -> DeclHead () -dhead n = DHead () (Ident () n) - -mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () -mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds - -mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl () -mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls) - where instrule = IRule () Nothing (Just ctxt) insthead - insthead = foldl' f (IHCon () (unqual n)) typs - where f acc x = IHApp () acc (tyParen x) - -mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () -#if MIN_VERSION_haskell_src_exts(1,20,0) -mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) -#else -mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls mderiv -#endif - where declhead = mkDeclHead n tbinds - -mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () -#if MIN_VERSION_haskell_src_exts(1,20,0) -mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv) -#else -mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls mderiv -#endif - where declhead = mkDeclHead n tbinds - -mkForImpCcall :: String -> String -> Type () -> Decl () -mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlaySafe () False)) (Just quote) (Ident () n) typ - -mkModule :: String -> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module () -mkModule n pragmas idecls decls = Module () (Just mhead) pragmas idecls decls - where mhead = ModuleHead () (ModuleName () n) Nothing Nothing - -mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () -mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls - where mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist) - eslist = ExportSpecList () exps - -mkImport :: String -> ImportDecl () -mkImport m = ImportDecl () (ModuleName () m) False False False Nothing Nothing Nothing - -mkImportExp :: String -> [String] -> ImportDecl () -mkImportExp m lst = - ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) - where islist = ImportSpecList () False (map mkIVar lst) - - -mkImportSrc :: String -> ImportDecl () -mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing - -lang :: [String] -> ModulePragma () -lang ns = LanguagePragma () (map (Ident ()) ns) - -dot :: Exp () -> Exp () -> Exp () -x `dot` y = x `app` mkVar "." `app` y - -tyForall = TyForall () - -tyParen = TyParen () - -tyPtr :: Type () -tyPtr = tycon "Ptr" - -tyForeignPtr :: Type () -tyForeignPtr = tycon "ForeignPtr" - -classA :: QName () -> [Type ()] -> Asst () -classA = ClassA () - -cxEmpty :: Context () -cxEmpty = CxEmpty () - -cxTuple :: [Asst ()] -> Context () -cxTuple = CxTuple () - -tySplice :: Splice () -> Type () -tySplice = TySplice () - -parenSplice :: Exp () -> Splice () -parenSplice = ParenSplice () - -bracketExp = BracketExp () -typeBracket = TypeBracket () - - -#if MIN_VERSION_haskell_src_exts(1,20,0) -mkDeriving = Deriving () Nothing -#else -mkDeriving = Deriving () -#endif - -irule = IRule () - -ihcon = IHCon () - -evar = EVar () -eabs = EAbs () -ethingwith = EThingWith () - -ethingall q = ethingwith (EWildcard () 0) q [] - -emodule nm = EModuleContents () (ModuleName () nm) - -nonamespace = NoNamespace () - -list = List () -lambda = Lambda () - -insType = InsType () -insDecl = InsDecl () - -generator = Generator () - -clsDecl = ClsDecl () - - -unkindedVar = UnkindedVar () diff --git a/src/FFICXX/Generate/Builder.hs b/src/FFICXX/Generate/Builder.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Builder.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module FFICXX.Generate.Builder where + +import Control.Monad ( void, when ) +import qualified Data.ByteString.Lazy.Char8 as L +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 + , createDirectoryIfMissing + , doesFileExist + ) +import System.IO ( hPutStrLn, withFile, IOMode(..) ) +import System.Process ( readProcess ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) +-- +import FFICXX.Generate.Code.Cabal ( buildCabalFile + , buildJSONFile + ) +import FFICXX.Generate.Dependency ( findModuleUnitImports + , mkHSBOOTCandidateList + , mkPackageConfig + ) +import FFICXX.Generate.Config ( FFICXXConfig(..) + , SimpleBuilderConfig(..) + ) +import FFICXX.Generate.ContentMaker +import FFICXX.Generate.Type.Cabal ( Cabal(..) + , CabalName(..) + , AddCInc(..) + , AddCSrc(..) + ) +import FFICXX.Generate.Type.Class ( hasProxy ) +import FFICXX.Generate.Type.Module ( ClassImportHeader(..) + , ClassModule(..) + , PackageConfig(..) + , TemplateClassModule(..) + , TopLevelImportHeader(..) + ) +import FFICXX.Generate.Util ( moduleDirFile ) +-- + +macrofy :: String -> String +macrofy = map ((\x->if x=='-' then '_' else x) . toUpper) + + +simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO () +simpleBuilder cfg sbc = do + putStrLn "----------------------------------------------------" + putStrLn "-- fficxx code generation for Haskell-C++ binding --" + putStrLn "----------------------------------------------------" + let SimpleBuilderConfig + topLevelMod + mumap + cabal + classes + toplevelfunctions + templates + extralibs + extramods + staticFiles + = sbc + pkgname = cabal_pkgname cabal + putStrLn ("Generating " <> unCabalName pkgname) + let workingDir = fficxxconfig_workingDir cfg + installDir = fficxxconfig_installBaseDir cfg + staticDir = fficxxconfig_staticFileDir cfg + + pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) = + mkPackageConfig + (pkgname, findModuleUnitImports mumap) + (classes, toplevelfunctions,templates,extramods) + (cabal_additional_c_incs cabal) + (cabal_additional_c_srcs cabal) + hsbootlst = mkHSBOOTCandidateList mods + cabalFileName = unCabalName pkgname <.> "cabal" + jsonFileName = unCabalName pkgname <.> "json" + -- + createDirectoryIfMissing True workingDir + createDirectoryIfMissing True installDir + createDirectoryIfMissing True (installDir "src") + createDirectoryIfMissing True (installDir "csrc") + -- + putStrLn "Copying static files" + mapM_ (\x->copyFileWithMD5Check (staticDir x) (installDir x)) staticFiles + -- + putStrLn "Generating Cabal file" + buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDircabalFileName) + -- + putStrLn "Generating JSON file" + buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDirjsonFileName) + -- + putStrLn "Generating Header file" + let + gen :: FilePath -> String -> IO () + gen file str = + let path = workingDir file in withFile path WriteMode (flip hPutStrLn str) + + + gen (unCabalName pkgname <> "Type.h") (buildTypeDeclHeader (map cihClass cihs)) + for_ cihs $ \hdr -> gen + (unHdrName (cihSelfHeader hdr)) + (buildDeclHeader (unCabalName pkgname) hdr) + gen + (tihHeaderFileName tih <.> "h") + (buildTopLevelHeader (unCabalName pkgname) tih) + + putStrLn "Generating Cpp file" + for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) + gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih) + -- + 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 "Generating RawType.hs" + for_ mods $ \m -> gen + (cmModule m <.> "RawType" <.> "hs") + (prettyPrint (buildRawTypeHs m)) + -- + putStrLn "Generating FFI.hsc" + for_ mods $ \m -> gen + (cmModule m <.> "FFI" <.> "hsc") + (prettyPrint (buildFFIHsc m)) + -- + putStrLn "Generating Interface.hs" + for_ mods $ \m -> gen + (cmModule m <.> "Interface" <.> "hs") + (prettyPrint (buildInterfaceHs mempty m)) + -- + putStrLn "Generating Cast.hs" + for_ mods $ \m -> gen + (cmModule m <.> "Cast" <.> "hs") + (prettyPrint (buildCastHs m)) + -- + putStrLn "Generating Implementation.hs" + for_ mods $ \m -> gen + (cmModule m <.> "Implementation" <.> "hs") + (prettyPrint (buildImplementationHs mempty m)) + -- + putStrLn "Generating Proxy.hs" + for_ mods $ \m -> + when (hasProxy . cihClass . cmCIH $ m) $ + gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (buildProxyHs 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)) + + -- + -- 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 "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) (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] "") + + +copyFileWithMD5Check :: FilePath -> FilePath -> IO () +copyFileWithMD5Check src tgt = do + b <- doesFileExist tgt + if b + then do + srcmd5 <- md5 <$> L.readFile src + tgtmd5 <- md5 <$> L.readFile tgt + if srcmd5 == tgtmd5 then return () else copyFile src tgt + else copyFile src tgt + + +copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO () +copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ _tcihs acincs acsrcs) = do + let thfile = cprefix <> "Type.h" + tlhfile = tihHeaderFileName tih <.> "h" + tlcppfile = tihHeaderFileName tih <.> "cpp" + copyFileWithMD5Check (wdir thfile) (ddir thfile) + doesFileExist (wdir tlhfile) + >>= flip when (copyFileWithMD5Check (wdir tlhfile) (ddir tlhfile)) + doesFileExist (wdir tlcppfile) + >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) + for_ cihs $ \header-> do + let hfile = unHdrName (cihSelfHeader header) + cppfile = cihSelfCpp header + copyFileWithMD5Check (wdir hfile) (ddir hfile) + copyFileWithMD5Check (wdir cppfile) (ddir cppfile) + + for_ acincs $ \(AddCInc header _) -> + copyFileWithMD5Check (wdir header) (ddir header) + + for_ acsrcs $ \(AddCSrc csrc _) -> + copyFileWithMD5Check (wdir csrc) (ddir csrc) + + +moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO () +moduleFileCopy wdir ddir fname = do + let (fnamebody,fnameext) = splitExtension fname + (mdir,mfile) = moduleDirFile fnamebody + origfpath = wdir fname + (mfile',_mext') = splitExtension mfile + newfpath = ddir mdir mfile' <> fnameext + b <- doesFileExist origfpath + when b $ do + createDirectoryIfMissing True (ddir mdir) + copyFileWithMD5Check origfpath newfpath + + +copyModule :: FilePath -> FilePath -> ClassModule -> IO () +copyModule wdir ddir m = do + let modbase = cmModule m + moduleFileCopy wdir ddir $ modbase <> ".hs" + moduleFileCopy wdir ddir $ modbase <> ".RawType.hs" + moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc" + moduleFileCopy wdir ddir $ modbase <> ".Interface.hs" + moduleFileCopy wdir ddir $ modbase <> ".Cast.hs" + moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs" + moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot" + when (hasProxy . cihClass . cmCIH $ m) $ + moduleFileCopy wdir ddir $ modbase <> ".Proxy.hs" + + +copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO () +copyTemplateModule wdir ddir m = do + let modbase = tcmModule m + moduleFileCopy wdir ddir $ modbase <> ".Template.hs" + moduleFileCopy wdir ddir $ modbase <> ".TH.hs" diff --git a/src/FFICXX/Generate/Code/Cabal.hs b/src/FFICXX/Generate/Code/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/Cabal.hs @@ -0,0 +1,283 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.Cabal where + +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.Runtime.CodeGen.Cxx ( HeaderName(..) ) +-- +import FFICXX.Generate.Type.Cabal ( AddCInc(..) + , AddCSrc(..) + , BuildType(..) + , CabalName(..) + , Cabal(..) + , GeneratedCabalInfo(..) + ) +import FFICXX.Generate.Type.Class ( hasProxy ) +import FFICXX.Generate.Type.Module +-- import FFICXX.Generate.Type.PackageInterface +import FFICXX.Generate.Util + + +cabalIndentation :: Text +cabalIndentation = T.replicate 23 " " + + +unlinesWithIndent = T.unlines . map (cabalIndentation <>) + +-- for source distribution +genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) + -> [AddCInc] + -> [AddCSrc] + -> [String] +genCsrcFiles (tih,cmods) acincs acsrcs = + let selfheaders' = do + x <- cmods + let y = cmCIH x + return (cihSelfHeader y) + selfheaders = nub selfheaders' + selfcpp' = do + x <- cmods + let y = cmCIH x + return (cihSelfCpp y) + selfcpp = nub selfcpp' + tlh = tihHeaderFileName tih <.> "h" + tlcpp = tihHeaderFileName tih <.> "cpp" + 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->"csrc"x) $ + (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) + ++ map (\(AddCSrc src _) -> src) acsrcs + + + in includeFileStrsWithCsrc <> cppFilesWithCsrc + +-- for library +genIncludeFiles :: String -- ^ package name + -> ([ClassImportHeader],[TemplateClassImportHeader]) + -> [AddCInc] + -> [String] +genIncludeFiles pkgname (cih,_tcih) acincs = + let selfheaders = map cihSelfHeader cih + includeFileStrs = map unHdrName (selfheaders ++ map (\(AddCInc hdr _) -> HdrName hdr) acincs) + in (pkgname<>"Type.h") : includeFileStrs + +-- for library +genCppFiles :: (TopLevelImportHeader,[ClassModule]) + -> [AddCSrc] + -> [String] +genCppFiles (tih,cmods) acsrcs = + let selfcpp' = do + x <- cmods + let y = cmCIH x + return (cihSelfCpp y) + selfcpp = nub selfcpp' + tlcpp = tihHeaderFileName tih <.> "cpp" + cppFileStrs = map (\x -> "csrc" x) $ + (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp) + ++ map (\(AddCSrc src _) -> src) acsrcs + in cppFileStrs + +-- | generate exposed module list in cabal file +genExposedModules :: String -> ([ClassModule],[TemplateClassModule]) -> [String] +genExposedModules summarymod (cmods,tmods) = + let cmodstrs = map cmModule cmods + rawType = map ((<>".RawType") . cmModule) cmods + ffi = map (( <>".FFI") . cmModule) cmods + interface = map ((<>".Interface") . cmModule) cmods + cast = map ((<>".Cast") . cmModule) cmods + implementation = map ((<>".Implementation") . cmModule) cmods + proxy = map ((<>".Proxy") . cmModule) + . filter (hasProxy . cihClass . cmCIH) + $ cmods + template = map ((<>".Template") . tcmModule) tmods + th = map ((<>".TH") . tcmModule) tmods + in [summarymod] + <> cmodstrs + <> rawType + <> ffi + <> interface + <> cast + <> implementation + <> proxy + <> template + <> th + +-- | 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 = + "Name: $pkgname\n\ + \Version: $version\n\ + \Synopsis: $synopsis\n\ + \Description: $description\n\ + \Homepage: $homepage\n\ + \$licenseField\n\ + \$licenseFileField\n\ + \Author: $author\n\ + \Maintainer: $maintainer\n\ + \Category: $category\n\ + \Tested-with: GHC >= 7.6\n\ + \$buildtype\n\ + \cabal-version: >= 2\n\ + \Extra-source-files:\n\ + \$extraFiles\n\ + \$csrcFiles\n\ + \\n\ + \$sourcerepository\n\ + \\n\ + \Library\n\ + \ default-language: Haskell2010\n\ + \ hs-source-dirs: src\n\ + \ ghc-options: -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\ + \ ghc-prof-options: -caf-all -auto-all\n\ + \ cxx-options: $cxxOptions\n\ + \ Build-Depends: $pkgdeps\n\ + \ Exposed-Modules:\n\ + \$exposedModules\n\ + \ Other-Modules:\n\ + \$otherModules\n\ + \ extra-lib-dirs: $extralibdirs\n\ + \ extra-libraries: $extraLibraries\n\ + \ Include-dirs: csrc $extraincludedirs\n\ + \ pkgconfig-depends: $pkgconfigDepends\n\ + \ Install-includes:\n\ + \$includeFiles\n\ + \ C-sources:\n\ + \$cppFiles\n" + + + +-- 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 = 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 = case cabal_buildType cabal of + Simple -> + "Build-Type: Simple" + Custom deps -> + "Build-Type: Custom\ncustom-setup\n setup-depends: " + <> T.pack (intercalate ", " (map unCabalName deps)) + <> "\n" + , gci_extraFiles = map T.pack extrafiles + , gci_csrcFiles = map T.pack $ genCsrcFiles (tih,classmodules) acincs acsrcs + , gci_sourcerepository = "" + , gci_cxxOptions = ["-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) + , ("cxxOptions" , T.intercalate " " gci_cxxOptions) + , ("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/src/FFICXX/Generate/Code/Cpp.hs b/src/FFICXX/Generate/Code/Cpp.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/Cpp.hs @@ -0,0 +1,711 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.Cpp where + +import Data.Char ( toUpper ) +import Data.Functor.Identity ( Identity ) +import Data.List ( intercalate, intersperse ) +import Data.Monoid ( (<>) ) +-- +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH ( IsCPrimitive(CPrim, NonCPrim) ) +-- +import FFICXX.Generate.Code.Primitive + ( accessorCFunSig + , argToCallCExp + , argsToCTypVar + , argsToCTypVarNoSelf + , c2Cxx + , cxx2C + , CFunSig(..) + , genericFuncArgs + , genericFuncRet + , returnCType + , tmplAccessorToTFun + , tmplAllArgsToCTypVar + , tmplAppTypeFromForm + , tmplArgToCallCExp + , tmplMemFuncArgToCTypVar + , tmplMemFuncReturnCType + , tmplReturnCType + ) +import FFICXX.Generate.Name ( aliasedFuncName + , cppFuncName + , ffiClassName + , ffiTmplFuncName + , hsTemplateMemberFunctionName + ) +import FFICXX.Generate.Type.Class ( Accessor(Getter,Setter) + , Arg(..) + , Class(..) + , CPPTypes(..) + , CTypes(..) + , Form(FormSimple,FormNested) + , Function(..) + , IsConst(Const,NoConst) + , Selfness(NoSelf,Self) + , TemplateAppInfo(..) + , TemplateClass(..) + , TemplateFunction(..) + , TemplateMemberFunction(..) + , TopLevel(..) + , Types(..) + , Variable(..) + , argsFromOpExp + , isDeleteFunc + , isNewFunc + , isStaticFunc + , isVirtualFunc + , opSymbol + , virtualFuncs + ) +import FFICXX.Generate.Type.Module ( ClassImportHeader(..) ) +import FFICXX.Generate.Util ( toUppers ) + +-- +-- +-- Class Declaration and Definition +-- + +---- +---- Declaration +---- + +---- "Class Type Declaration" Instances + +typedefStmts :: String -> [R.CStatement Identity] +typedefStmts classname = + [ R.TypeDef (R.CTVerbatim ("struct " <> classname_tag)) (R.sname classname_t) + , R.TypeDef (R.CTVerbatim (classname_t <> " *")) (R.sname classname_p) + , R.TypeDef (R.CTVerbatim (classname_t <> " const*")) (R.sname ("const_" <> classname_p)) + ] + where + classname_tag = classname <> "_tag" + classname_t = classname <> "_t" + classname_p = classname <> "_p" + + +genCppHeaderMacroType :: Class -> [R.CStatement Identity] +genCppHeaderMacroType c = + [ R.Comment "Opaque type definition for $classname" ] + <> typedefStmts (ffiClassName c) + + +---- "Class Declaration Virtual" Declaration + +genCppHeaderMacroVirtual :: Class -> R.CMacro Identity +genCppHeaderMacroVirtual aclass = + let funcDecls = map R.CDeclaration + . map (funcToDecl aclass) + . virtualFuncs + . class_funcs + $ aclass + macrocname = map toUpper (ffiClassName aclass) + macroname = macrocname <> "_DECL_VIRT" + in R.Define (R.sname macroname) [R.sname "Type"] funcDecls + +genCppHeaderMacroNonVirtual :: Class -> R.CMacro Identity +genCppHeaderMacroNonVirtual c = + let funcDecls = map R.CDeclaration + . map (funcToDecl c) + . filter (not.isVirtualFunc) + . class_funcs + $ c + macrocname = map toUpper (ffiClassName c) + macroname = macrocname <> "_DECL_NONVIRT" + in R.Define (R.sname macroname) [R.sname "Type"] funcDecls + + +---- "Class Declaration Accessor" Declaration + +genCppHeaderMacroAccessor :: Class -> R.CMacro Identity +genCppHeaderMacroAccessor c = + let funcDecls = map R.CDeclaration $ accessorsToDecls (class_vars c) + macrocname = map toUpper (ffiClassName c) + macroname = macrocname <> "_DECL_ACCESSOR" + in R.Define (R.sname macroname) [R.sname "Type"] funcDecls + + +---- "Class Declaration Virtual/NonVirtual/Accessor" Instances + +genCppHeaderInstVirtual :: (Class,Class) -> R.CStatement Identity +genCppHeaderInstVirtual (p,c) = + let macroname = map toUpper (ffiClassName p) <> "_DECL_VIRT" + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + +genCppHeaderInstNonVirtual :: Class -> R.CStatement Identity +genCppHeaderInstNonVirtual c = + let macroname = map toUpper (ffiClassName c) <> "_DECL_NONVIRT" + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + +genCppHeaderInstAccessor :: Class -> R.CStatement Identity +genCppHeaderInstAccessor c = + let macroname = map toUpper (ffiClassName c) <> "_DECL_ACCESSOR" + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + +---- +---- Definition +---- + +---- "Class Definition Virtual" Declaration + +genCppDefMacroVirtual :: Class -> R.CMacro Identity +genCppDefMacroVirtual aclass = + let funcDefStr = intercalate "\n" + . map (R.renderCStmt . funcToDef aclass) + . virtualFuncs + . class_funcs + $ aclass + macrocname = map toUpper (ffiClassName aclass) + macroname = macrocname <> "_DEF_VIRT" + in R.Define (R.sname macroname) [R.sname "Type"] [ R.CVerbatim funcDefStr ] + +---- "Class Definition NonVirtual" Declaration + +genCppDefMacroNonVirtual :: Class -> R.CMacro Identity +genCppDefMacroNonVirtual aclass = + let funcDefStr = intercalate "\n" + . map (R.renderCStmt . funcToDef aclass) + . filter (not.isVirtualFunc) + . class_funcs + $ aclass + macrocname = map toUpper (ffiClassName aclass) + macroname = macrocname <> "_DEF_NONVIRT" + in R.Define (R.sname macroname) [R.sname "Type"] [ R.CVerbatim funcDefStr ] + +---- Define Macro to provide Accessor C-C++ shim code for a class + +genCppDefMacroAccessor :: Class -> R.CMacro Identity +genCppDefMacroAccessor c = + let funcDefs = concatMap (\v -> [accessorToDef v Getter,accessorToDef v Setter]) (class_vars c) + macrocname = map toUpper (ffiClassName c) + macroname = macrocname <> "_DEF_ACCESSOR" + in R.Define (R.sname macroname) [R.sname "Type"] funcDefs + +---- Define Macro to provide TemplateMemberFunction C-C++ shim code for a class + +genCppDefMacroTemplateMemberFunction :: + Class + -> TemplateMemberFunction + -> R.CMacro Identity +genCppDefMacroTemplateMemberFunction c f = + R.Define (R.sname macroname) (map R.sname (tmf_params f)) + [ R.CExtern [R.CDeclaration decl] + , tmplMemberFunToDef c f + , autoinst + ] + where + nsuffix = intersperse (R.NamePart "_") $ map R.NamePart (tmf_params f) + macroname = hsTemplateMemberFunctionName c f + decl = tmplMemberFunToDecl c f + autoinst = + R.CInit + (R.CVarDecl + R.CTAuto + (R.CName (R.NamePart ("a_" <> macroname <> "_") : nsuffix)) + ) + (R.CVar (R.CName (R.NamePart (macroname <> "_") : nsuffix))) + + +---- Invoke Macro to define Virtual/NonVirtual method for a class + +genCppDefInstVirtual :: (Class, Class) -> R.CStatement Identity +genCppDefInstVirtual (p,c) = + let macroname = map toUpper (ffiClassName p) <> "_DEF_VIRT" + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + +genCppDefInstNonVirtual :: Class -> R.CStatement Identity +genCppDefInstNonVirtual c = + let macroname = toUppers (ffiClassName c) <> "_DEF_NONVIRT" + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + +genCppDefInstAccessor :: Class -> R.CStatement Identity +genCppDefInstAccessor c = + let macroname = toUppers (ffiClassName c) <> "_DEF_ACCESSOR" + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + +----------------- + +genAllCppHeaderInclude :: ClassImportHeader -> [R.CMacro Identity] +genAllCppHeaderInclude header = + map R.Include (cihIncludedHPkgHeadersInCPP header <> cihIncludedCPkgHeaders header) + +---- + +------------------------- +-- TOP LEVEL FUNCTIONS -- +------------------------- + +topLevelDecl :: TopLevel -> R.CFunDecl Identity +topLevelDecl TopLevelFunction {..} = R.CFunDecl ret func args + where + ret = returnCType toplevelfunc_ret + func = R.sname ("TopLevel_" <> maybe toplevelfunc_name id toplevelfunc_alias) + args = argsToCTypVarNoSelf toplevelfunc_args +topLevelDecl TopLevelVariable {..} = R.CFunDecl ret func [] + where + ret = returnCType toplevelvar_ret + func = R.sname ("TopLevel_" <> maybe toplevelvar_name id toplevelvar_alias) + +genTopLevelCppDefinition :: TopLevel -> R.CStatement Identity +genTopLevelCppDefinition tf@TopLevelFunction {..} = + let decl = topLevelDecl tf + body = returnCpp + NonCPrim + (toplevelfunc_ret) + (R.CApp (R.CVar (R.sname toplevelfunc_name)) (map argToCallCExp toplevelfunc_args)) + in R.CDefinition Nothing decl body +genTopLevelCppDefinition tv@TopLevelVariable {..} = + let decl = topLevelDecl tv + body = returnCpp NonCPrim (toplevelvar_ret) (R.CVar (R.sname toplevelvar_name)) + in R.CDefinition Nothing decl body + +genTmplFunCpp :: + IsCPrimitive + -> TemplateClass + -> TemplateFunction + -> R.CMacro Identity +genTmplFunCpp b t@TmplCls {..} f = + R.Define (R.sname macroname) (map R.sname ("callmod" : tclass_params)) + [ R.CExtern [R.CDeclaration decl] + , tmplFunToDef b t f + , autoinst + ] + where + nsuffix = intersperse (R.NamePart "_") $ map R.NamePart tclass_params + suffix = case b of { CPrim -> "_s"; NonCPrim -> "" } + macroname = tclass_name <> "_" <> ffiTmplFuncName f <> suffix + decl = tmplFunToDecl b t f + autoinst = + R.CInit + (R.CVarDecl + R.CTAuto + (R.CName (R.NamePart "a_" : R.NamePart "callmod" : R.NamePart ("_" <> tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix )) + ) + (R.CVar (R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix ))) + +genTmplVarCpp :: + IsCPrimitive + -> TemplateClass + -> Variable + -> [ R.CMacro Identity ] +genTmplVarCpp b t@TmplCls {..} var@(Variable (Arg {..})) = + [ gen var Getter, gen var Setter ] + where + nsuffix = intersperse (R.NamePart "_") $ map R.NamePart tclass_params + suffix = case b of { CPrim -> "_s"; NonCPrim -> "" } + gen v a = + let f = tmplAccessorToTFun v a + macroname = tclass_name <> "_" <> ffiTmplFuncName f <> suffix + in R.Define (R.sname macroname) (map R.sname ("callmod" : tclass_params)) + [ R.CExtern [R.CDeclaration (tmplFunToDecl b t f)] + , tmplVarToDef b t v a + , R.CInit + (R.CVarDecl + R.CTAuto + (R.CName (R.NamePart "a_" : R.NamePart "callmod" : R.NamePart ("_" <> tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix )) + ) + (R.CVar (R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix ))) + ] + +-- | +genTmplClassCpp :: + IsCPrimitive + -> TemplateClass + -> ([TemplateFunction],[Variable]) -- ^ (member functions, member accessors) + -> R.CMacro Identity +genTmplClassCpp b TmplCls {..} (fs,vs) = + R.Define (R.sname macroname) params body + where + params = map R.sname ("callmod" : tclass_params) + suffix = case b of { CPrim -> "_s"; NonCPrim -> "" } + tname = tclass_name + macroname = tname <> "_instance" <> suffix + macro1 f@TFun {..} = R.CMacroApp (R.sname (tname <> "_" <> ffiTmplFuncName f <> suffix)) params + macro1 f@TFunNew {..} = R.CMacroApp (R.sname (tname <> "_" <> ffiTmplFuncName f <> suffix)) params + macro1 TFunDelete = R.CMacroApp (R.sname (tname <> "_delete" <> suffix)) params + macro1 f@TFunOp {..} = R.CMacroApp (R.sname (tname <> "_" <> ffiTmplFuncName f <> suffix)) params + body = map macro1 fs + ++ (map macro1 . concatMap (\v -> [tmplAccessorToTFun v Getter, tmplAccessorToTFun v Setter])) vs + +-- | +returnCpp :: + IsCPrimitive + -> Types + -> R.CExp Identity + -> [R.CStatement Identity] +returnCpp b ret caller = + case ret of + Void -> + [ R.CExpSA caller ] + SelfType -> + [R.CReturn $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t" ]) + , R.CTSimple (R.sname "Type") ] + [ R.CCast (R.CTStar (R.CTSimple (R.sname "Type"))) caller ] + ] + CT (CRef _) _ -> + [R.CReturn $ R.CAddr caller ] + CT _ _ -> + [R.CReturn caller ] + CPT (CPTClass c') isconst -> + [R.CReturn $ + R.CTApp + (case isconst of + NoConst -> R.sname "from_nonconst_to_nonconst" + Const -> R.sname "from_const_to_nonconst" + ) + [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ] + [ R.CCast (R.CTStar (R.CTSimple (R.sname str))) caller ] + ] + where str = ffiClassName c' + CPT (CPTClassRef c') isconst -> + [R.CReturn $ + R.CTApp + (case isconst of + NoConst -> R.sname "from_nonconst_to_nonconst" + Const -> R.sname "from_const_to_nonconst" + ) + [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ] + [ R.CAddr caller ] + ] + where str = ffiClassName c' + CPT (CPTClassCopy c') isconst -> + [R.CReturn $ + R.CTApp + (case isconst of + NoConst -> R.sname "from_nonconst_to_nonconst" + Const -> R.sname "from_const_to_nonconst" + ) + [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ] + [ R.CNew (R.sname str) [ caller ] ] + ] + where str = ffiClassName c' + CPT (CPTClassMove c') isconst -> -- TODO: check whether this is working or not. + [R.CReturn $ + R.CApp + (R.CVar (R.sname "std::move")) + [R.CTApp + (case isconst of + NoConst -> R.sname "from_nonconst_to_nonconst" + Const -> R.sname "from_const_to_nonconst" + ) + [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ] + [ R.CAddr caller ] + ] + ] + where str = ffiClassName c' + TemplateApp (TemplateAppInfo _ _ cpptype) -> + [ R.CInit + (R.CVarDecl (R.CTStar (R.CTVerbatim cpptype)) (R.sname "r")) + (R.CNew (R.sname cpptype) [ caller ]) + , R.CReturn $ + R.CTApp + (R.sname "static_cast") + [ R.CTStar R.CTVoid ] + [ R.CVar (R.sname "r") ] + ] + TemplateAppRef (TemplateAppInfo _ _ cpptype) -> + [ R.CInit + (R.CVarDecl (R.CTStar (R.CTVerbatim cpptype)) (R.sname "r")) + (R.CNew (R.sname cpptype) [ caller ]) + , R.CReturn $ + R.CTApp + (R.sname "static_cast") + [ R.CTStar R.CTVoid ] + [ R.CVar (R.sname "r") ] + ] + TemplateAppMove (TemplateAppInfo _ _ cpptype) -> + [ R.CInit + (R.CVarDecl (R.CTStar (R.CTVerbatim cpptype)) (R.sname "r")) + (R.CNew (R.sname cpptype) [ caller ]) + , R.CReturn $ + R.CApp + (R.CVar (R.sname "std::move")) + [R.CTApp + (R.sname "staic_cast") + [ R.CTStar R.CTVoid ] + [ R.CVar (R.sname "r") ] + ] + ] + TemplateType _ -> + error "returnCpp: TemplateType" + TemplateParam typ -> + [ R.CReturn $ + case b of + CPrim -> caller + NonCPrim -> + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t" ]), R.CTSimple (R.sname typ) ] + [ R.CCast (R.CTStar (R.CTSimple (R.sname typ))) $ R.CAddr caller ] + ] + TemplateParamPointer typ -> + [ R.CReturn $ + case b of + CPrim -> caller + NonCPrim -> + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t"]), R.CTSimple (R.sname typ) ] + [ caller ] + ] + +-- Function Declaration and Definition + +funcToDecl :: Class -> Function -> R.CFunDecl Identity +funcToDecl c func + | isNewFunc func || isStaticFunc func = + let ret = returnCType (genericFuncRet func) + fname = + R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)] + args = argsToCTypVarNoSelf (genericFuncArgs func) + in R.CFunDecl ret fname args + | otherwise = + let ret = returnCType (genericFuncRet func) + fname = + R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)] + args = argsToCTypVar (genericFuncArgs func) + in R.CFunDecl ret fname args + +funcToDef :: Class -> Function -> R.CStatement Identity +funcToDef c func + | isNewFunc func = + let body = [ R.CInit + (R.CVarDecl (R.CTStar (R.CTSimple (R.sname "Type"))) (R.sname "newp")) + (R.CNew (R.sname "Type") $ map argToCallCExp (genericFuncArgs func)) + , R.CReturn $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t"]), R.CTSimple (R.sname "Type") ] + [ R.CVar (R.sname "newp") ] + ] + in R.CDefinition Nothing (funcToDecl c func) body + | isDeleteFunc func = + let body = [ R.CDelete $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname "Type"), R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t" ]) ] + [ R.CVar (R.sname "p") ] + ] + in R.CDefinition Nothing (funcToDecl c func) body + | isStaticFunc func = + let body = returnCpp NonCPrim (genericFuncRet func) $ + R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func)) + in R.CDefinition Nothing (funcToDecl c func) body + | otherwise = + let caller = + R.CBinOp + R.CArrow + (R.CApp + (R.CEMacroApp + (R.sname "TYPECASTMETHOD") + [ R.sname "Type", R.sname (aliasedFuncName c func), R.sname (class_name c) ] + ) + [ R.CVar (R.sname "p") ] + ) + (R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func))) + body = returnCpp NonCPrim (genericFuncRet func) caller + in R.CDefinition Nothing (funcToDecl c func) body + +-- template function declaration and definition + + +tmplFunToDecl :: + IsCPrimitive + -> TemplateClass + -> TemplateFunction + -> R.CFunDecl Identity +tmplFunToDecl b t@TmplCls {..} f = + let nsuffix = intersperse (R.NamePart "_") $ map R.NamePart tclass_params + in case f of + TFun {..} -> + let ret = tmplReturnCType b tfun_ret + func = R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix) + args = tmplAllArgsToCTypVar b Self t tfun_args + in R.CFunDecl ret func args + TFunNew {..} -> + let ret = tmplReturnCType b (TemplateType t) + func = R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix) + args = tmplAllArgsToCTypVar b NoSelf t tfun_new_args + in R.CFunDecl ret func args + TFunDelete -> + let ret = R.CTVoid + func = R.CName (R.NamePart (tclass_name <> "_delete_") : nsuffix) + args = tmplAllArgsToCTypVar b Self t [] + in R.CFunDecl ret func args + TFunOp {..} -> + let ret = tmplReturnCType b tfun_ret + func = R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix) + args = tmplAllArgsToCTypVar b Self t (argsFromOpExp tfun_opexp) + in R.CFunDecl ret func args + +-- | +tmplFunToDef :: + IsCPrimitive + -> TemplateClass + -> TemplateFunction + -> R.CStatement Identity +tmplFunToDef b t@TmplCls {..} f = + R.CDefinition (Just R.Inline) (tmplFunToDecl b t f) body + where + typparams = map (R.CTSimple . R.sname) tclass_params + body = + case f of + TFunNew {..} -> + let caller = + case tclass_cxxform of + FormSimple tclass -> + R.CTNew + (R.sname tclass) + typparams + (map (tmplArgToCallCExp b) tfun_new_args) + FormNested tclass inner -> + R.CTNewI + (R.sname tclass) + (R.sname inner) + typparams + (map (tmplArgToCallCExp b) tfun_new_args) + in [ R.CReturn $ R.CTApp (R.sname "static_cast") [R.CTStar R.CTVoid] [caller] ] + TFunDelete -> + [ R.CDelete $ + R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ] + [ R.CVar (R.sname "p") ] + ] + TFun {..} -> + returnCpp b (tfun_ret) $ + R.CBinOp + R.CArrow + (R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ] + [ R.CVar $ R.sname "p" ] + ) + (R.CApp + (R.CVar (R.sname tfun_oname)) + (map (tmplArgToCallCExp b) tfun_args) + ) + TFunOp {..} -> + returnCpp b (tfun_ret) $ + R.CBinOp + R.CArrow + (R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ] + [ R.CVar $ R.sname "p" ] + ) + (R.CApp + (R.CVar (R.sname ("operator" <> opSymbol tfun_opexp))) + (map (tmplArgToCallCExp b) (argsFromOpExp tfun_opexp)) + ) + + +tmplVarToDef :: + IsCPrimitive + -> TemplateClass + -> Variable + -> Accessor + -> R.CStatement Identity +tmplVarToDef b t@TmplCls {..} v@(Variable (Arg {..})) a = + R.CDefinition (Just R.Inline) (tmplFunToDecl b t f) body + where + f = tmplAccessorToTFun v a + typparams = map (R.CTSimple . R.sname) tclass_params + body = + case f of + TFun {..} -> + let varexp = R.CBinOp + R.CArrow + (R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ] + [ R.CVar $ R.sname "p" ] + ) + (R.CVar (R.sname arg_name)) + in case a of + Getter -> returnCpp b (tfun_ret) varexp + Setter -> [ R.CExpSA $ + R.CBinOp + R.CAssign + varexp + (c2Cxx arg_type (R.CVar (R.sname "value"))) + ] + _ -> error "tmplVarToDef: should not happen" + +-- Accessor Declaration and Definition + +accessorToDecl :: Variable -> Accessor -> R.CFunDecl Identity +accessorToDecl v a = + let csig = accessorCFunSig (arg_type (unVariable v)) a + ret = returnCType (cRetType csig) + fname = + R.CName [ R.NamePart "Type" + , R.NamePart ( "_" + <> arg_name (unVariable v) + <> "_" + <> case a of Getter -> "get"; Setter -> "set" + ) + ] + args = argsToCTypVar (cArgTypes csig) + in R.CFunDecl ret fname args + +accessorsToDecls :: [Variable] -> [R.CFunDecl Identity] +accessorsToDecls vs = + concatMap (\v -> [accessorToDecl v Getter,accessorToDecl v Setter]) vs + +accessorToDef :: Variable -> Accessor -> R.CStatement Identity +accessorToDef v a = + let varexp = + R.CBinOp + R.CArrow + (R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname "Type"), R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t"]) ] + [ R.CVar (R.sname "p") ] + ) + (R.CVar (R.sname (arg_name (unVariable v)))) + body Getter = R.CReturn $ cxx2C (arg_type (unVariable v)) varexp + body Setter = R.CExpSA $ + R.CBinOp + R.CAssign + varexp + (c2Cxx (arg_type (unVariable v)) (R.CVar (R.sname "x"))) + in R.CDefinition Nothing (accessorToDecl v a) [ body a ] + + +-- Template Member Function Declaration and Definition + +-- TODO: Handle simple type +tmplMemberFunToDecl :: Class -> TemplateMemberFunction -> R.CFunDecl Identity +tmplMemberFunToDecl c f = + let nsuffix = intersperse (R.NamePart "_") $ map R.NamePart (tmf_params f) + ret = tmplMemFuncReturnCType c (tmf_ret f) + fname = + R.CName (R.NamePart (hsTemplateMemberFunctionName c f <> "_") : nsuffix) + args = map (tmplMemFuncArgToCTypVar c) ((Arg SelfType "p"):tmf_args f) + in R.CFunDecl ret fname args + +-- TODO: Handle simple type +tmplMemberFunToDef :: Class -> TemplateMemberFunction -> R.CStatement Identity +tmplMemberFunToDef c f = + R.CDefinition (Just R.Inline) (tmplMemberFunToDecl c f) body + where + tparams = map (R.CTSimple . R.sname) (tmf_params f) + body = returnCpp NonCPrim (tmf_ret f) $ + R.CBinOp + R.CArrow + (R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname (ffiClassName c)), R.CTSimple (R.sname (ffiClassName c <> "_t")) ] + [ R.CVar $ R.sname "p" ] + ) + (R.CTApp + (R.sname (tmf_name f)) + tparams + (map (tmplArgToCallCExp NonCPrim) (tmf_args f)) + ) diff --git a/src/FFICXX/Generate/Code/HsCast.hs b/src/FFICXX/Generate/Code/HsCast.hs new file mode 100644 --- /dev/null +++ b/src/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/src/FFICXX/Generate/Code/HsFFI.hs b/src/FFICXX/Generate/Code/HsFFI.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/HsFFI.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsFFI where + +import Data.Maybe ( fromMaybe, mapMaybe ) +import Data.Monoid ( (<>) ) +import Language.Haskell.Exts.Syntax ( Decl(..), ImportDecl(..) ) +import System.FilePath ( (<.>) ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) +-- +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 ( Accessor(Getter,Setter) + , Arg(..) + , Class(..) + , Function(..) + , Selfness(NoSelf,Self) + , TopLevel(..) + , Variable(unVariable) + , isAbstractClass + , isNewFunc + , isStaticFunc + , virtualFuncs + ) +import FFICXX.Generate.Type.Module ( ClassImportHeader(..) + , ClassModule(..) + , TopLevelImportHeader(..) + ) +import FFICXX.Generate.Util ( toLowers ) +import FFICXX.Generate.Util.HaskellSrcExts ( mkForImpCcall, mkImport ) + + +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 + -- 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 + then Nothing + else let hfile = unHdrName headerfilename + -- 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)) 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 <> "_" <> arg_name (unVariable v) <> "_" <> (case a of Getter -> "get"; Setter -> "set") + typ = hsFFIFuncTyp (Just (Self,c)) (accessorCFunSig (arg_type (unVariable 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 -- +---------------------------- + +genTopLevelFFI :: TopLevelImportHeader -> TopLevel -> Decl () +genTopLevelFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ + where (fname,args,ret) = + case tfn of + TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret) + TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret) + hfilename = tihHeaderFileName header <.> "h" + -- TODO: This must be exposed as a top-level function + cfname = "c_" <> toLowers fname + typ =hsFFIFuncTyp Nothing (CFunSig args ret) diff --git a/src/FFICXX/Generate/Code/HsFrontEnd.hs b/src/FFICXX/Generate/Code/HsFrontEnd.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -0,0 +1,322 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsFrontEnd where + +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 + ,hsClassName + ,hscAccessorName + ,hscFuncName + ,hsFuncName + ,hsFrontNameForTopLevel + ,typeclassName + ) +import FFICXX.Generate.Dependency (class_allparents + ,extractClassDepForTopLevel + ,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 + let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body + sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) + body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c + return cdecl + +------------------- + +genHsFrontInst :: Class -> Class -> [Decl ()] +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 + 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 + -> Reader AnnotateMap [Decl ()] +genHsFrontInstNew c = do + -- amap <- ask + let fs = filter isNewFunc (class_funcs c) + return . flip concatMap fs $ \f -> + let + -- for the time being, let's ignore annotation. + -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap + -- newfuncann = mkComment 0 cann + rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing + +genHsFrontInstNonVirtual :: Class -> [Decl ()] +genHsFrontInstNonVirtual c = + flip concatMap nonvirtualFuncs $ \f -> + let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing + where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) + +----- + +genHsFrontInstStatic :: Class -> [Decl ()] +genHsFrontInstStatic c = + flip concatMap (staticFuncs (class_funcs c)) $ \f -> + let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing + +----- + +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 + + + + +-------------------------- + +hsClassRawType :: Class -> [Decl ()] +hsClassRawType c = + [ mkData rawname [] [] Nothing + , mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv + , mkInstance cxEmpty "FPtr" [hightype] + [ insType (tyapp (tycon "Raw") hightype) rawtype + , 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 + rawtype = tycon rawname + 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")) + + +------------ +-- upcast -- +------------ + +genHsFrontUpcastClass :: Class -> [Decl ()] +genHsFrontUpcastClass c = mkFun ("upcast"<>highname) typ [mkPVar "h"] rhs Nothing + where (highname,rawname) = hsClassName c + hightype = tycon highname + rawtype = tycon rawname + iname = typeclassName c + a_bind = unkindedVar (name "a") + a_tvar = mkTVar "a" + typ = tyForall (Just [a_bind]) + (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]])) + (tyfun a_tvar hightype) + rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing + , pbind (mkPVarSig "fh2" (tyapp tyPtr rawtype)) + (app (mkVar "castPtr") (mkVar "fh")) Nothing + ] + (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") + + +-------------- +-- downcast -- +-------------- + +genHsFrontDowncastClass :: Class -> [Decl ()] +genHsFrontDowncastClass c = mkFun ("downcast"<>highname) typ [mkPVar "h"] rhs Nothing + where (highname,_rawname) = hsClassName c + hightype = tycon highname + iname = typeclassName c + a_bind = unkindedVar (name "a") + a_tvar = mkTVar "a" + typ = tyForall (Just [a_bind]) + (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]])) + (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") + + +------------------------ +-- Top Level Function -- +------------------------ + + +genTopLevelDef :: TopLevel -> [Decl ()] +genTopLevelDef f@TopLevelFunction {..} = + let fname = hsFrontNameForTopLevel f + 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 + rhs = app (mkVar xformerstr) (mkVar cfname) + + in mkFun fname sig [] rhs Nothing +genTopLevelDef v@TopLevelVariable {..} = + let fname = hsFrontNameForTopLevel v + 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 + + +------------ +-- Export -- +------------ + +genExport :: Class -> [ExportSpec ()] +genExport c = + let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) + then eabs nonamespace (unqual n) + else ethingall (unqual n) + 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 + +-- | 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 + <> nonVirtualNotNewFuncs fs) + +-- | staic function export list +genExportStatic :: Class -> [ExportSpec ()] +genExportStatic c = map (evar . unqual) fns + where fs = class_funcs c + fns = map (aliasedFuncName c) (staticFuncs fs) + + +------------ +-- Import -- +------------ + +genExtraImport :: ClassModule -> [ImportDecl ()] +genExtraImport cm = map mkImport (cmExtraImport cm) + + +genImportInModule :: Class -> [ImportDecl ()] +genImportInModule x = map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"] + + +genImportInInterface :: ClassModule -> [ImportDecl ()] +genImportInInterface m = + let modlstraw = cmImportedModulesRaw m + modlstparent = cmImportedModulesHighNonSource m + modlsthigh = cmImportedModulesHighSource m + in [mkImport (cmModule m <.> "RawType")] + <> 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 = + let modlstraw' = cmImportedModulesForFFI m + modlsthigh = nub $ map Right $ class_allparents $ cihClass $ cmCIH 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 (\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 + + +-- | generate import list for a given top-level function +-- currently this may generate duplicate import list. +-- TODO: eliminate duplicated imports. +genImportForTopLevel :: TopLevel -> [ImportDecl ()] +genImportForTopLevel f = + let dep4func = extractClassDepForTopLevel 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 + +-- | 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 genImportForTopLevel tfns + diff --git a/src/FFICXX/Generate/Code/HsProxy.hs b/src/FFICXX/Generate/Code/HsProxy.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/HsProxy.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FFICXX.Generate.Code.HsProxy where + +import Language.Haskell.Exts.Build ( app, doE, listE, qualStmt, strE ) +import qualified Data.List as L ( foldr1 ) +import Language.Haskell.Exts.Syntax ( Decl(..) ) +-- +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Generate.Util.HaskellSrcExts + ( con, inapp, mkFun, mkVar + , op, qualifier + , tyapp, tycon, tylist + ) + + +genProxyInstance :: [Decl ()] +genProxyInstance = + mkFun fname sig [] rhs Nothing + where fname = "genImplProxy" + v = mkVar + sig = tycon "Q" `tyapp` tylist (tycon "Dec") + rhs = doE [foreignSrcStmt, qualStmt retstmt] + foreignSrcStmt = + qualifier $ + (v "addModFinalizer") + `app` ( v "addForeignSource" + `app` con "LangCxx" + `app` (L.foldr1 (\x y -> inapp x (op "++") y) + [ includeStatic ] + ) + ) + where + includeStatic = + strE $ concatMap (<> "\n") + [ R.renderCMacro (R.Include "MacroPatternMatch.h") ] + retstmt = v "pure" `app` listE [] diff --git a/src/FFICXX/Generate/Code/HsTemplate.hs b/src/FFICXX/Generate/Code/HsTemplate.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/HsTemplate.hs @@ -0,0 +1,440 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.HsTemplate where + +import Data.Monoid ( (<>) ) +import qualified Data.List as L ( foldr1 ) +import Language.Haskell.Exts.Build ( app, binds, caseE, doE + , lamE, letE, letStmt, listE, name + , pApp, paren, pTuple + , qualStmt, strE, tuple, wildcard + ) +import Language.Haskell.Exts.Syntax ( Boxed(Boxed), Decl(..), ImportDecl(..), Type(TyTuple) ) +import System.FilePath ( (<.>) ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH ( IsCPrimitive(CPrim,NonCPrim) ) +-- +import FFICXX.Generate.Code.Cpp ( genTmplClassCpp + , genTmplFunCpp + , genTmplVarCpp + ) +import FFICXX.Generate.Code.Primitive ( functionSignatureT + , functionSignatureTT + , functionSignatureTMF + , tmplAccessorToTFun + ) +import FFICXX.Generate.Code.HsCast ( castBody ) +import FFICXX.Generate.Dependency ( getClassModuleBase + , getTClassModuleBase + , mkModuleDepRaw + , mkModuleDepHighSource + ) +import FFICXX.Generate.Name ( ffiTmplFuncName + , hsTemplateClassName + , hsTemplateMemberFunctionName + , hsTemplateMemberFunctionNameTH + , hsTmplFuncName + , hsTmplFuncNameTH + , tmplAccessorName + , typeclassNameT + ) +import FFICXX.Generate.Type.Class ( Accessor(Getter,Setter) + , Arg(..) + , Class(..) + , TemplateClass(..) + , TemplateFunction(..) + , TemplateMemberFunction(..) + , Variable(..) + , Types(Void) + ) +import FFICXX.Generate.Type.Module ( ClassImportHeader(..) + , TemplateClassImportHeader(..) + ) +import FFICXX.Generate.Util.HaskellSrcExts + ( bracketExp + , con, conDecl, cxEmpty, clsDecl + , generator + , inapp, insDecl, insType + , match, mkBind1, mkTBind, mkData, mkNewtype + , mkFun, mkFunSig, mkClass, mkImport, mkInstance + , mkPVar, mkTVar, mkVar + , op, pbind_ + , qualConDecl, qualifier + , tyapp, tycon, tyfun, tylist, tyPtr + , typeBracket + ) + + +------------------------------ +-- Template member function -- +------------------------------ + +genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()] +genTemplateMemberFunctions cih = + let c = cihClass cih + in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c) + +-- TODO: combine this with genTmplInstance +genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()] +genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + where + nh = hsTemplateMemberFunctionNameTH c f + v = mkVar + p = mkPVar + itps = zip ([1..]::[Int]) (tmf_params f) + tvars = map (\(i,_) -> "typ" ++ show i) itps + nparams = length itps + tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type")) + sig = foldr1 tyfun [tparams , tycon "String", tyapp (tycon "Q") (tycon "Exp") ] + tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] + lit' = strE (hsTemplateMemberFunctionName c f <> "_") + lam = lamE [p "n"] ( lit' `app` v "<>" `app` v "n") + rhs = app (v "mkTFunc") $ + let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] + in tuple (typs ++ [ v "suffix", lam, v "tyf"]) + sig' = functionSignatureTMF c f + tassgns = map (\(i,tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + bstmts = binds [ mkBind1 "tyf" [mkPVar "n"] + (letE tassgns + (bracketExp (typeBracket sig'))) + Nothing + ] + +genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [Decl ()] +genTMFInstance cih f = + mkFun + fname + sig + [p "isCprim", pTuple [p "qtyp", p "param"]] + rhs + Nothing + where + c = cihClass cih + fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f + p = mkPVar + v = mkVar + sig = tycon "IsCPrimitive" + `tyfun` TyTuple () Boxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"] + `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec")) + rhs = doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, letStmt lststmt, qualStmt retstmt] + suffixstmt = letStmt [ pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param" ) ] + 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") (listE ([v "f1"])) ] + retstmt = v "pure" `app` v "lst" + -- TODO: refactor out the following code. + foreignSrcStmt = + qualifier $ + (v "addModFinalizer") + `app` ( v "addForeignSource" + `app` con "LangCxx" + `app` (L.foldr1 (\x y -> inapp x (op "++") y) + [ includeStatic + , includeDynamic + , namespaceStr + , strE (hsTemplateMemberFunctionName c f) + , strE "(" + , v "suffix" + , strE ")\n" + ] + ) + ) + where + includeStatic = + strE $ concatMap ((<>"\n") . R.renderCMacro . R.Include) $ + [ HdrName "MacroPatternMatch.h", cihSelfHeader cih ] + <> cihIncludedHPkgHeadersInCPP cih + <> cihIncludedCPkgHeaders cih + includeDynamic = + letE + [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param" ) + , pbind_ (pApp (name "f") [p "x"]) + (v "renderCMacro" `app` (con "Include" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "headers") + namespaceStr = + letE + [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param" ) + , pbind_ (pApp (name "f") [p "x"]) + (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "nss") + +-------------------- +-- Template Class -- +-------------------- + +genImportInTemplate :: TemplateClass -> [ImportDecl ()] +genImportInTemplate t0 = + let + deps_raw = mkModuleDepRaw (Left t0) + deps_high = mkModuleDepHighSource (Left t0) + in flip map deps_raw + (\case + Left t -> mkImport (getTClassModuleBase t <.> "Template") + Right c -> mkImport (getClassModuleBase c <.> "RawType") + ) + <> flip map deps_high + (\case + Left t -> mkImport (getTClassModuleBase t <.> "Template") + Right c -> mkImport (getClassModuleBase c <.> "Interface") + ) + +-- | +genTmplInterface :: TemplateClass -> [Decl ()] +genTmplInterface t = + [ mkData rname (map mkTBind tps) [] Nothing + , mkNewtype hname (map mkTBind tps) + [ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing + , mkClass cxEmpty (typeclassNameT t) (map mkTBind tps) methods + , mkInstance cxEmpty "FPtr" [ hightype ] fptrbody + , mkInstance cxEmpty "Castable" [ hightype, tyapp tyPtr rawtype ] castBody + ] + where + (hname,rname) = hsTemplateClassName t + tps = tclass_params t + fs = tclass_funcs t + vfs = tclass_vars t + rawtype = foldl1 tyapp (tycon rname : map mkTVar tps) + hightype = foldl1 tyapp (tycon hname : map mkTVar tps) + sigdecl f = mkFunSig (hsTmplFuncName t f) (functionSignatureT t f) + sigdeclV vf = let f_g = tmplAccessorToTFun vf Getter + f_s = tmplAccessorToTFun vf Setter + in [sigdecl f_g, sigdecl f_s] + methods = map (clsDecl . sigdecl) fs ++ (map clsDecl . concatMap sigdeclV) vfs + + 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) + ] + +-- | +genImportInTH :: TemplateClass -> [ImportDecl ()] +genImportInTH t0 = + let + deps_raw = mkModuleDepRaw (Left t0) + deps_high = mkModuleDepHighSource (Left t0) + in flip concatMap deps_raw + (\case + Left t -> [mkImport (getTClassModuleBase t <.> "Template")] + Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType","Cast","Interface"] + ) + <> flip concatMap deps_high + (\case + Left t -> [mkImport (getTClassModuleBase t <.> "Template")] + Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType","Cast","Interface"] + ) + +-- | +genTmplImplementation :: TemplateClass -> [Decl ()] +genTmplImplementation t = + concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars t) + where + v = mkVar + p = mkPVar + itps = zip ([1..]::[Int]) (tclass_params t) + tvars = map (\(i,_) -> "typ" ++ show i) itps + nparams = length itps + tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type")) + sig = foldr1 tyfun [tparams , tycon "String", tyapp (tycon "Q") (tycon "Exp") ] + tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)] + prefix = tclass_name t + + gen f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + where nh = hsTmplFuncNameTH t f + nc = ffiTmplFuncName f + lit' = strE (prefix<>"_"<>nc) + lam = lamE [p "n"] ( lit' `app` v "<>" `app` v "n") + rhs = app (v "mkTFunc") $ + let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)] + in tuple (typs ++ [ v "suffix", lam, v "tyf"]) + sig' = functionSignatureTT t f + tassgns = map (\(i,tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + bstmts = binds [ mkBind1 "tyf" [wildcard] -- [mkPVar "n"] + (letE tassgns + (bracketExp (typeBracket sig'))) + Nothing + ] + + genV vf = let f_g = tmplAccessorToTFun vf Getter + f_s = tmplAccessorToTFun vf Setter + in gen f_g ++ gen f_s + +-- | +genTmplInstance :: + TemplateClassImportHeader + -> [Decl ()] +genTmplInstance tcih = + mkFun + fname + sig + (p "isCprim" : zipWith (\x y -> pTuple [p x,p y]) qtvars pvars) + rhs + Nothing + where + t = tcihTClass tcih + fs = tclass_funcs t + vfs = tclass_vars t + tname = tclass_name t + fname = "gen" <> tname <> "InstanceFor" + p = mkPVar + v = mkVar + itps = zip ([1..]::[Int]) (tclass_params t) + tvars = map (\(i,_) -> "typ" ++ show i) itps + qtvars = map (\(i,_) -> "qtyp" ++ show i) itps + pvars = map (\(i,_) -> "param" ++ show i) itps + nparams = length itps + typs_v = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars) + params_l = listE (map v pvars) + sig = foldr1 tyfun $ + [ tycon "IsCPrimitive" ] + ++ replicate + nparams + (TyTuple () Boxed [ tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo" ]) + ++ [ tycon "Q" `tyapp` tylist (tycon "Dec") ] + nfs = zip ([1..] :: [Int]) fs + nvfs = zip ([1..] :: [Int]) vfs + -------------------------- + -- final RHS expression -- + -------------------------- + rhs = doE ( [ paramsstmt, suffixstmt ] + <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location")) + , letStmt [ pbind_ (p "callmod") + (v "dot2_" `app` v "callmod_") ] + ] + <> map genqtypstmt (zip tvars qtvars) + <> map genstmt nfs + <> concatMap genvarstmt nvfs + <> [foreignSrcStmt, letStmt lststmt, qualStmt retstmt] + ) + -------------------------- + paramsstmt = letStmt [ pbind_ + (p "params") + (v "map" `app` (v "tpinfoSuffix") `app` params_l) + ] + + suffixstmt = letStmt [ pbind_ + (p "suffix") + ( v "concatMap" + `app` (lamE [p "x"] (inapp (strE "_") (op "++") (v "tpinfoSuffix" `app` v "x"))) + `app` params_l + ) + ] + + genqtypstmt (tvar,qtvar) = generator (p tvar) (v qtvar) + gen prefix nm f n = + generator + (p (prefix<>show n)) + (v nm `app` strE (hsTmplFuncName t f) + `app` v (hsTmplFuncNameTH t f) + `app` typs_v + `app` v "suffix" + ) + genstmt (n,f@TFun {..}) = gen "f" "mkMember" f n + genstmt (n,f@TFunNew {..}) = gen "f" "mkNew" f n + genstmt (n,f@TFunDelete) = gen "f" "mkDelete" f n + genstmt (n,f@TFunOp {..}) = gen "f" "mkMember" f n + genvarstmt (n,vf) = + let + Variable (Arg {..}) = vf + f_g = TFun { tfun_ret = arg_type + , tfun_name = tmplAccessorName vf Getter + , tfun_oname = tmplAccessorName vf Getter + , tfun_args = [] + } + f_s = TFun { tfun_ret = Void + , tfun_name = tmplAccessorName vf Setter + , tfun_oname = tmplAccessorName vf Setter + , tfun_args = [Arg arg_type "value"] + } + in [ gen "vf" "mkMember" f_g (2*n-1) + , gen "vf" "mkMember" f_s (2*n) + ] + + lststmt = let mkElems prefix xs = map (v . (\n->prefix<>show n) . fst) xs + in [ pbind_ + (p "lst") + (listE ( mkElems "f" nfs + <> mkElems "vf" (concatMap (\(n,vf) -> [(2*n-1,vf),(2*n,vf)]) nvfs) + ) + ) + ] + + -- TODO: refactor out the following code. + foreignSrcStmt = + qualifier $ + (v "addModFinalizer") + `app` ( v "addForeignSource" + `app` con "LangCxx" + `app` (L.foldr1 (\x y -> inapp x (op "++") y) + [ includeStatic + , includeDynamic + , namespaceStr + , strE (tname <> "_instance") + , paren $ + caseE + (v "isCprim") + [ match (p "CPrim") (strE "_s") + , match (p "NonCPrim") (strE "") + ] + , strE "(" + , v "intercalate" `app` + strE ", " `app` + paren (inapp (v "callmod") (op ":") (v "params")) + , strE ")\n" + ] + ) + ) + where + -- temporary + body = map R.renderCMacro $ + map R.Include (tcihCxxHeaders tcih) + ++ map (genTmplFunCpp NonCPrim t) fs + ++ map (genTmplFunCpp CPrim t) fs + ++ concatMap (genTmplVarCpp NonCPrim t) vfs + ++ concatMap (genTmplVarCpp CPrim t) vfs + ++ [ genTmplClassCpp NonCPrim t (fs,vfs) + , genTmplClassCpp CPrim t (fs,vfs) + ] + includeStatic = + strE $ concatMap (<> "\n") + ( [ R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h")) ] + ++ body + ) + cxxHeaders = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l + cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l + includeDynamic = + letE + [ pbind_ (p "headers") cxxHeaders + , pbind_ (pApp (name "f") [p "x"]) + (v "renderCMacro" `app` (con "Include" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "headers") + namespaceStr = + letE + [ pbind_ (p "nss") cxxNamespaces + , pbind_ (pApp (name "f") [p "x"]) + (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x")) + ] + (v "concatMap" `app` v "f" `app` v "nss") + + retstmt = v "pure" + `app` listE [ v "mkInstance" + `app` listE [] + `app` foldl1 + (\f x -> con "AppT" `app` f `app` x) + (v "con" `app` strE (typeclassNameT t) : map v tvars) + `app` (v "lst") + ] diff --git a/src/FFICXX/Generate/Code/Primitive.hs b/src/FFICXX/Generate/Code/Primitive.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Code/Primitive.hs @@ -0,0 +1,1006 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.Primitive where + +import Control.Monad.Trans.State ( runState, put, get ) +import Data.Functor.Identity ( Identity ) +import Data.Monoid ( (<>) ) +import Language.Haskell.Exts.Syntax ( Asst(..), Context, Type(..) ) +-- +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH ( IsCPrimitive(CPrim,NonCPrim) ) +-- +import FFICXX.Generate.Name ( ffiClassName + , hsClassName + , hsClassNameForTArg + , hsTemplateClassName + , tmplAccessorName + , typeclassName + , typeclassNameFromStr + ) +import FFICXX.Generate.Type.Class ( Accessor(Getter,Setter) + , Arg(..) + , Class(..) + , CPPTypes(..) + , CTypes(..) + , Form(..) + , Function(..) + , IsConst(Const,NoConst) + , Selfness(NoSelf,Self) + , TemplateAppInfo(..) + , TemplateArgType(TArg_TypeParam) + , TemplateClass(..) + , TemplateFunction(..) + , TemplateMemberFunction(..) + , Types(..) + , Variable(..) + , argsFromOpExp + , isNonVirtualFunc + , isVirtualFunc + ) +import FFICXX.Generate.Util.HaskellSrcExts + ( classA, cxTuple, mkTVar, mkVar, parenSplice, tyapp, tycon, tyfun, tyPtr, tySplice + , unit_tycon, unqual ) + + +data CFunSig = CFunSig { cArgTypes :: [Arg] + , cRetType :: Types + } + +data HsFunSig = HsFunSig { hsSigTypes :: [Type ()] + , hsSigConstraints :: [Asst ()] + } + +ctypToCType :: CTypes -> IsConst -> R.CType Identity +ctypToCType ctyp isconst = + let typ = case ctyp of + CTBool -> R.CTSimple $ R.sname "bool" + CTChar -> R.CTSimple $ R.sname "char" + CTClock -> R.CTSimple $ R.sname "clock_t" + CTDouble -> R.CTSimple $ R.sname "double" + CTFile -> R.CTSimple $ R.sname "FILE" + CTFloat -> R.CTSimple $ R.sname "float" + CTFpos -> R.CTSimple $ R.sname "fpos_t" + CTInt -> R.CTSimple $ R.sname "int" + CTIntMax -> R.CTSimple $ R.sname "intmax_t" + CTIntPtr -> R.CTSimple $ R.sname "intptr_t" + CTJmpBuf -> R.CTSimple $ R.sname "jmp_buf" + CTLLong -> R.CTSimple $ R.sname "long long" + CTLong -> R.CTSimple $ R.sname "long" + CTPtrdiff -> R.CTSimple $ R.sname "ptrdiff_t" + CTSChar -> R.CTSimple $ R.sname "sized char" + CTSUSeconds -> R.CTSimple $ R.sname "suseconds_t" + CTShort -> R.CTSimple $ R.sname "short" + CTSigAtomic -> R.CTSimple $ R.sname "sig_atomic_t" + CTSize -> R.CTSimple $ R.sname "size_t" + CTTime -> R.CTSimple $ R.sname "time_t" + CTUChar -> R.CTSimple $ R.sname "unsigned char" + CTUInt -> R.CTSimple $ R.sname "unsigned int" + CTUIntMax -> R.CTSimple $ R.sname "uintmax_t" + CTUIntPtr -> R.CTSimple $ R.sname "uintptr_t" + CTULLong -> R.CTSimple $ R.sname "unsigned long long" + CTULong -> R.CTSimple $ R.sname "unsigned long" + CTUSeconds -> R.CTSimple $ R.sname "useconds_t" + CTUShort -> R.CTSimple $ R.sname "unsigned short" + CTWchar -> R.CTSimple $ R.sname "wchar_t" + CTInt8 -> R.CTSimple $ R.sname "int8_t" + CTInt16 -> R.CTSimple $ R.sname "int16_t" + CTInt32 -> R.CTSimple $ R.sname "int32_t" + CTInt64 -> R.CTSimple $ R.sname "int64_t" + CTUInt8 -> R.CTSimple $ R.sname "uint8_t" + CTUInt16 -> R.CTSimple $ R.sname "uint16_t" + CTUInt32 -> R.CTSimple $ R.sname "uint32_t" + CTUInt64 -> R.CTSimple $ R.sname "uint64_t" + CTString -> R.CTStar $ R.CTSimple $ R.sname "char" + CTVoidStar -> R.CTStar R.CTVoid + CEnum _ type_str -> R.CTVerbatim type_str + CPointer s -> R.CTStar (ctypToCType s NoConst) + CRef s -> R.CTStar (ctypToCType s NoConst) + in case isconst of + Const -> R.CTConst typ + NoConst -> typ + +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 + +cshort_ :: Types +cshort_ = CT CTShort Const + +short_ :: Types +short_ = CT CTShort NoConst + +cdouble_ :: Types +cdouble_ = CT CTDouble Const + +double_ :: Types +double_ = CT CTDouble NoConst + +doublep_ :: Types +doublep_ = CT (CPointer CTDouble) NoConst + +cfloat_ :: Types +cfloat_ = CT CTFloat Const + +float_ :: Types +float_ = CT CTFloat NoConst + +bool_ :: Types +bool_ = CT CTBool NoConst + +void_ :: Types +void_ = Void + +voidp_ :: Types +voidp_ = CT CTVoidStar NoConst + +intp_ :: Types +intp_ = CT (CPointer CTInt) NoConst + +intref_ :: Types +intref_ = CT (CRef CTInt) NoConst + + +charpp_ :: Types +charpp_ = CT (CPointer CTString) 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 -> Arg +self var = Arg self_ var + +voidp :: String -> Arg +voidp var = Arg voidp_ var + +cstring :: String -> Arg +cstring var = Arg cstring_ var + +cint :: String -> Arg +cint var = Arg cint_ var + +int :: String -> Arg +int var = Arg int_ var + +uint :: String -> Arg +uint var = Arg uint_ var + +long :: String -> Arg +long var = Arg long_ var + +ulong :: String -> Arg +ulong var = Arg ulong_ var + +clong :: String -> Arg +clong var = Arg clong_ var + +culong :: String -> Arg +culong var = Arg culong_ var + +cchar :: String -> Arg +cchar var = Arg cchar_ var + +char :: String -> Arg +char var = Arg char_ var + +cshort :: String -> Arg +cshort var = Arg cshort_ var + +short :: String -> Arg +short var = Arg short_ var + +cdouble :: String -> Arg +cdouble var = Arg cdouble_ var + +double :: String -> Arg +double var = Arg double_ var + +doublep :: String -> Arg +doublep var = Arg doublep_ var + +cfloat :: String -> Arg +cfloat var = Arg float_ var + +float :: String -> Arg +float var = Arg float_ var + +bool :: String -> Arg +bool var = Arg bool_ var + +intp :: String -> Arg +intp var = Arg intp_ var + +intref :: String -> Arg +intref var = Arg intref_ var + +charpp :: String -> Arg +charpp var = Arg charpp_ var + +ref :: CTypes -> String -> Arg +ref t var = Arg (ref_ t) var + +star :: CTypes -> String -> Arg +star t var = Arg (star_ t) var + +cstar :: CTypes -> String -> Arg +cstar t var = Arg (cstar_ t) var + + +cppclass_ :: Class -> Types +cppclass_ c = CPT (CPTClass c) NoConst + +cppclass :: Class -> String -> Arg +cppclass c vname = Arg (cppclass_ c) vname + + + +cppclassconst :: Class -> String -> Arg +cppclassconst c vname = Arg (CPT (CPTClass c) Const) vname + +cppclassref_ :: Class -> Types +cppclassref_ c = CPT (CPTClassRef c) NoConst + +cppclassref :: Class -> String -> Arg +cppclassref c vname = Arg (cppclassref_ c) vname + +cppclasscopy_ :: Class -> Types +cppclasscopy_ c = CPT (CPTClassCopy c) NoConst + +cppclasscopy :: Class -> String -> Arg +cppclasscopy c vname = Arg (cppclasscopy_ c) vname + +cppclassmove_ :: Class -> Types +cppclassmove_ c = CPT (CPTClassMove c) NoConst + +cppclassmove :: Class -> String -> Arg +cppclassmove c vname = Arg (cppclassmove_ c) vname + + +argToCTypVar :: Arg -> (R.CType Identity, R.CName Identity) +argToCTypVar (Arg (CT ctyp isconst) varname) = + (ctypToCType ctyp isconst, R.sname varname) +argToCTypVar (Arg SelfType varname) = + (R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_p" ]), R.sname varname) +argToCTypVar (Arg (CPT (CPTClass c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname) + where cname = ffiClassName c +argToCTypVar (Arg (CPT (CPTClassRef c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname) + where cname = ffiClassName c +argToCTypVar (Arg (CPT (CPTClassCopy c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname) + where cname = ffiClassName c +argToCTypVar (Arg (CPT (CPTClassMove c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname) + where cname = ffiClassName c +argToCTypVar (Arg (TemplateApp _) varname) = (R.CTStar R.CTVoid, R.sname varname) +argToCTypVar (Arg (TemplateAppRef _) varname) = (R.CTStar R.CTVoid, R.sname varname) +argToCTypVar (Arg (TemplateAppMove _) varname) = (R.CTStar R.CTVoid, R.sname varname) +argToCTypVar t = error ("argToCTypVar: " <> show t) + +argsToCTypVar :: [Arg] -> [ (R.CType Identity, R.CName Identity) ] +argsToCTypVar args = + let args' = (Arg SelfType "p") : args + in map argToCTypVar args' + +argsToCTypVarNoSelf :: [Arg] -> [ (R.CType Identity, R.CName Identity) ] +argsToCTypVarNoSelf = map argToCTypVar + +argToCallCExp :: Arg -> R.CExp Identity +argToCallCExp (Arg t e) = c2Cxx t (R.CVar (R.sname e)) + + +-- TODO: rename this function by castExpressionFrom/To or something like that. +returnCType :: Types -> R.CType Identity +returnCType (CT ctyp isconst) = ctypToCType ctyp isconst +returnCType Void = R.CTVoid +returnCType SelfType = R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_p" ]) +returnCType (CPT (CPTClass c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +returnCType (CPT (CPTClassRef c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +returnCType (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +returnCType (CPT (CPTClassMove c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +returnCType (TemplateApp _) = R.CTStar R.CTVoid +returnCType (TemplateAppRef _) = R.CTStar R.CTVoid +returnCType (TemplateAppMove _) = R.CTStar R.CTVoid +returnCType (TemplateType _) = R.CTStar R.CTVoid +returnCType (TemplateParam t) = R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]) +returnCType (TemplateParamPointer t) = R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]) + +-- TODO: Rewrite this with static_cast +c2Cxx :: Types -> R.CExp Identity -> R.CExp Identity +c2Cxx t e = + case t of + CT (CRef _) _ -> R.CStar e + CPT (CPTClass c) _ -> R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ] + [ e ] + where f = ffiClassName c + CPT (CPTClassRef c) _ -> R.CTApp + (R.sname "from_nonconstref_to_nonconstref") + [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ] + [ R.CStar e ] + where f = ffiClassName c + CPT (CPTClassCopy c) _ -> R.CStar $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ] + [ e ] + where f = ffiClassName c + CPT (CPTClassMove c) _ -> R.CApp + (R.CVar (R.sname "std::move")) + [ R.CTApp + (R.sname "from_nonconstref_to_nonconstref") + [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ] + [ R.CStar e ] + ] + where f = ffiClassName c + TemplateApp p -> R.CTApp + (R.sname "from_nonconstref_to_nonconst") + [ R.CTVerbatim (tapp_CppTypeForParam p), R.CTVoid ] + [ e ] + TemplateAppRef p -> R.CStar $ + R.CCast (R.CTStar (R.CTVerbatim (tapp_CppTypeForParam p))) e + TemplateAppMove p -> R.CApp + (R.CVar (R.sname "std::move")) + [ R.CStar $ + R.CCast (R.CTStar (R.CTVerbatim (tapp_CppTypeForParam p))) e + ] + _ -> e + +-- TODO: Rewrite this with static_cast +-- Merge this with returnCpp after Void and simple type adjustment +-- TODO: Resolve all the error cases +cxx2C :: Types -> R.CExp Identity -> R.CExp Identity +cxx2C t e = + case t of + Void -> R.CNull + SelfType -> + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t"]), R.CTSimple (R.sname "Type") ] + [ R.CCast (R.CTStar (R.CTSimple (R.sname "Type"))) e ] + -- "to_nonconst((Type *)" <> e <> ")" + CT (CRef _) _ -> R.CAddr e + -- "&(" <> e <> ")" + CT _ _ -> e + -- e + CPT (CPTClass c) _ -> + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname (f <> "_t")), R.CTSimple (R.sname f) ] + [ R.CCast (R.CTStar (R.CTSimple (R.sname f))) e ] + where f = ffiClassName c + -- "to_nonconst<" <> f <> "_t," <> f <> ">((" <> f <> "*)" <> e <> ")" + CPT (CPTClassRef c) _ -> + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname (f <> "_t")), R.CTSimple (R.sname f) ] + [ R.CAddr e ] + where f = ffiClassName c + -- "to_nonconst<" <> f <> "_t," <> f <> ">(&(" <> e <> "))" + CPT (CPTClassCopy c) _ -> + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname (f <> "_t")), R.CTSimple (R.sname f) ] + [ R.CNew (R.sname f) [e] ] + where f = ffiClassName c + -- "to_nonconst<" <> f <> "_t," <> f <> ">(new " <> f <> "(" <> e <> "))" + CPT (CPTClassMove c) _ -> + R.CApp + (R.CVar (R.sname "std::move")) + [ R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname (f <> "_t")), R.CTSimple (R.sname f) ] + [ R.CAddr e ] + ] + where f = ffiClassName c + -- "std::move(to_nonconst<" <> f <> "_t," <> f <>">(&(" <> e <> ")))" + TemplateApp _ -> + error "cxx2C: TemplateApp" + -- g <> "* r = new " <> g <> "(" <> e <> "); " + -- <> "return (static_cast(r));" + TemplateAppRef _ -> + error "cxx2C: TemplateAppRef" + -- g <> "* r = new " <> g <> "(" <> e <> "); " + -- <> "return (static_cast(r));" + TemplateAppMove _ -> + error "cxx2C: TemplateAppMove" + TemplateType _ -> + error "cxx2C: TemplateType" + TemplateParam _ -> + error "cxx2C: TemplateParam" + -- if b then e + -- else "to_nonconst((Type *)&(" <> e <> "))" + TemplateParamPointer _ -> + error "cxx2C: TemplateParamPointer" + -- if b then "(" <> callstr <> ");" + -- else "to_nonconst(" <> e <> ") ;" + +tmplAppTypeFromForm :: Form -> [R.CType Identity] -> R.CType Identity +tmplAppTypeFromForm (FormSimple tclass) targs = R.CTTApp (R.sname tclass) targs +tmplAppTypeFromForm (FormNested tclass inner) targs = R.CTScoped (R.CTTApp (R.sname tclass) targs) (R.CTVerbatim inner) + +tmplArgToCTypVar :: + IsCPrimitive + -> TemplateClass + -> Arg + -> (R.CType Identity, R.CName Identity) +tmplArgToCTypVar _ _ (Arg (CT ctyp isconst) varname) = + (ctypToCType ctyp isconst, R.sname varname) +tmplArgToCTypVar _ _ (Arg SelfType varname) = + (R.CTStar R.CTVoid, R.sname varname) +tmplArgToCTypVar _ _ (Arg (CPT (CPTClass c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplArgToCTypVar _ _ (Arg (CPT (CPTClassRef c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplArgToCTypVar _ _ (Arg (CPT (CPTClassMove c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplArgToCTypVar _ _ (Arg (TemplateApp _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplArgToCTypVar _ _ (Arg (TemplateAppRef _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplArgToCTypVar _ _ (Arg (TemplateAppMove _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplArgToCTypVar _ _ (Arg (TemplateType _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplArgToCTypVar CPrim _ (Arg (TemplateParam t) v) = (R.CTSimple (R.sname t), R.sname v) +tmplArgToCTypVar NonCPrim _ (Arg (TemplateParam t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]), R.sname v) +tmplArgToCTypVar CPrim _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.sname t), R.sname v) +tmplArgToCTypVar NonCPrim _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p"]), R.sname v) +tmplArgToCTypVar _ _ _ = error "tmplArgToCTypVar: undefined" + +tmplAllArgsToCTypVar :: + IsCPrimitive + -> Selfness + -> TemplateClass + -> [Arg] + -> [ (R.CType Identity, R.CName Identity) ] +tmplAllArgsToCTypVar b s t args = + let args' = case s of + Self -> (Arg (TemplateType t) "p") : args + NoSelf -> args + in map (tmplArgToCTypVar b t) args' + +-- TODO: Rewrite this with static_cast. +-- Implement missing cases. +tmplArgToCallCExp + :: IsCPrimitive + -> Arg + -> R.CExp Identity +tmplArgToCallCExp _ (Arg (CPT (CPTClass c) _) varname) = + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname str), R.CTSimple (R.sname (str <> "_t")) ] + [ R.CVar (R.sname varname) ] + where str = ffiClassName c +tmplArgToCallCExp _ (Arg (CPT (CPTClassRef c) _) varname) = + R.CTApp + (R.sname "from_nonconstref_to_nonconstref") + [ R.CTSimple (R.sname str), R.CTSimple (R.sname (str <> "_t")) ] + [ R.CStar $ R.CVar $ R.sname varname ] + where str = ffiClassName c +tmplArgToCallCExp _ (Arg (CPT (CPTClassMove c) _) varname) = + R.CApp + (R.CVar (R.sname "std::move")) + [R.CTApp + (R.sname "from_nonconstref_to_nonconstref") + [ R.CTSimple (R.sname str), R.CTSimple (R.sname (str <> "_t")) ] + [ R.CStar $ R.CVar $ R.sname varname ] + ] + where str = ffiClassName c +tmplArgToCallCExp _ (Arg (CT (CRef _) _) varname) = + R.CStar $ R.CVar $ R.sname varname +tmplArgToCallCExp _ (Arg (TemplateApp x) varname) = + let targs = map (R.CTSimple . R.sname . hsClassNameForTArg) (tapp_tparams x) + in R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm (tclass_cxxform (tapp_tclass x)) targs ] + [ R.CVar $ R.sname varname ] +tmplArgToCallCExp _ (Arg (TemplateAppRef x) varname) = + let targs = map (R.CTSimple . R.sname . hsClassNameForTArg) (tapp_tparams x) + in R.CStar $ + R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm (tclass_cxxform (tapp_tclass x)) targs ] + [ R.CVar $ R.sname varname ] +tmplArgToCallCExp _ (Arg (TemplateAppMove x) varname) = + let targs = map (R.CTSimple . R.sname . hsClassNameForTArg) (tapp_tparams x) + in R.CApp + (R.CVar (R.sname "std::move")) + [ R.CStar $ + R.CTApp + (R.sname "static_cast") + [ R.CTStar $ tmplAppTypeFromForm (tclass_cxxform (tapp_tclass x)) targs ] + [ R.CVar $ R.sname varname ] + ] +tmplArgToCallCExp b (Arg (TemplateParam typ) varname) = + case b of + CPrim -> R.CVar $ R.sname varname + NonCPrim -> R.CStar $ + R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname typ), R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t"]) ] + [ R.CVar $ R.sname varname ] +tmplArgToCallCExp b (Arg (TemplateParamPointer typ) varname) = + case b of + CPrim -> R.CVar $ R.sname varname + NonCPrim -> R.CTApp + (R.sname "from_nonconst_to_nonconst") + [ R.CTSimple (R.sname typ), R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t"]) ] + [ R.CVar $ R.sname varname ] +tmplArgToCallCExp _ (Arg _ varname) = R.CVar $ R.sname varname + +tmplReturnCType :: + IsCPrimitive + -> Types + -> R.CType Identity +tmplReturnCType _ (CT ctyp isconst) = ctypToCType ctyp isconst +tmplReturnCType _ Void = R.CTVoid +tmplReturnCType _ SelfType = R.CTStar R.CTVoid +tmplReturnCType _ (CPT (CPTClass c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplReturnCType _ (CPT (CPTClassRef c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplReturnCType _ (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplReturnCType _ (CPT (CPTClassMove c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplReturnCType _ (TemplateApp _) = R.CTStar R.CTVoid +tmplReturnCType _ (TemplateAppRef _) = R.CTStar R.CTVoid +tmplReturnCType _ (TemplateAppMove _) = R.CTStar R.CTVoid +tmplReturnCType _ (TemplateType _) = R.CTStar R.CTVoid +tmplReturnCType b (TemplateParam t) = case b of + CPrim -> R.CTSimple $ R.sname t + NonCPrim -> R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ] +tmplReturnCType b (TemplateParamPointer t) = case b of + CPrim -> R.CTSimple $ R.sname t + NonCPrim -> R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ] + +-- --------------------------- +-- Template Member Function -- +-- --------------------------- + +-- | +tmplMemFuncArgToCTypVar :: Class -> Arg -> (R.CType Identity, R.CName Identity) +tmplMemFuncArgToCTypVar _ (Arg (CT ctyp isconst) varname) = + (ctypToCType ctyp isconst, R.sname varname) +tmplMemFuncArgToCTypVar c (Arg SelfType varname) = + (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClass c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClassRef c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClassMove c) isconst) varname) = + case isconst of + Const -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname) + NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname) +tmplMemFuncArgToCTypVar _ (Arg (TemplateApp _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplMemFuncArgToCTypVar _ (Arg (TemplateAppRef _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplMemFuncArgToCTypVar _ (Arg (TemplateAppMove _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplMemFuncArgToCTypVar _ (Arg (TemplateType _) v) = (R.CTStar R.CTVoid, R.sname v) +tmplMemFuncArgToCTypVar _ (Arg (TemplateParam t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]), R.sname v) +tmplMemFuncArgToCTypVar _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]), R.sname v) +tmplMemFuncArgToCTypVar _ _ = error "tmplMemFuncArgToString: undefined" + + +-- | +tmplMemFuncReturnCType :: Class -> Types -> R.CType Identity +tmplMemFuncReturnCType _ (CT ctyp isconst) = ctypToCType ctyp isconst +tmplMemFuncReturnCType _ Void = R.CTVoid +tmplMemFuncReturnCType c SelfType = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplMemFuncReturnCType _ (CPT (CPTClass c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplMemFuncReturnCType _ (CPT (CPTClassRef c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplMemFuncReturnCType _ (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplMemFuncReturnCType _ (CPT (CPTClassMove c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p")) +tmplMemFuncReturnCType _ (TemplateApp _) = R.CTStar R.CTVoid +tmplMemFuncReturnCType _ (TemplateAppRef _) = R.CTStar R.CTVoid +tmplMemFuncReturnCType _ (TemplateAppMove _) = R.CTStar R.CTVoid +tmplMemFuncReturnCType _ (TemplateType _) = R.CTStar R.CTVoid +tmplMemFuncReturnCType _ (TemplateParam t) = R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ] +tmplMemFuncReturnCType _ (TemplateParamPointer t) = R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ] + +-- | +convertC2HS :: CTypes -> Type () +convertC2HS CTBool = tycon "CBool" +convertC2HS CTChar = tycon "CChar" +convertC2HS CTClock = tycon "CClock" +convertC2HS CTDouble = tycon "CDouble" +convertC2HS CTFile = tycon "CFile" +convertC2HS CTFloat = tycon "CFloat" +convertC2HS CTFpos = tycon "CFpos" +convertC2HS CTInt = tycon "CInt" +convertC2HS CTIntMax = tycon "CIntMax" +convertC2HS CTIntPtr = tycon "CIntPtr" +convertC2HS CTJmpBuf = tycon "CJmpBuf" +convertC2HS CTLLong = tycon "CLLong" +convertC2HS CTLong = tycon "CLong" +convertC2HS CTPtrdiff = tycon "CPtrdiff" +convertC2HS CTSChar = tycon "CSChar" +convertC2HS CTSUSeconds = tycon "CSUSeconds" +convertC2HS CTShort = tycon "CShort" +convertC2HS CTSigAtomic = tycon "CSigAtomic" +convertC2HS CTSize = tycon "CSize" +convertC2HS CTTime = tycon "CTime" +convertC2HS CTUChar = tycon "CUChar" +convertC2HS CTUInt = tycon "CUInt" +convertC2HS CTUIntMax = tycon "CUIntMax" +convertC2HS CTUIntPtr = tycon "CUIntPtr" +convertC2HS CTULLong = tycon "CULLong" +convertC2HS CTULong = tycon "CULong" +convertC2HS CTUSeconds = tycon "CUSeconds" +convertC2HS CTUShort = tycon "CUShort" +convertC2HS CTWchar = tycon "CWchar" +convertC2HS CTInt8 = tycon "Int8" +convertC2HS CTInt16 = tycon "Int16" +convertC2HS CTInt32 = tycon "Int32" +convertC2HS CTInt64 = tycon "Int64" +convertC2HS CTUInt8 = tycon "Word8" +convertC2HS CTUInt16 = tycon "Word16" +convertC2HS CTUInt32 = tycon "Word32" +convertC2HS CTUInt64 = tycon "Word64" +convertC2HS CTString = tycon "CString" +convertC2HS CTVoidStar = tyapp (tycon "Ptr") unit_tycon +convertC2HS (CEnum t _) = convertC2HS t +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) = + foldl1 tyapp $ map tycon $ + tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) +convertCpp2HS _c (TemplateAppRef x) = + foldl1 tyapp $ map tycon $ + tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) +convertCpp2HS _c (TemplateAppMove x) = + foldl1 tyapp $ map tycon $ + tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x) +convertCpp2HS _c (TemplateType t) = + foldl1 tyapp $ + tycon (tclass_name t) : map mkTVar (tclass_params 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 = convertCpp2HS c Void +convertCpp2HS4Tmpl _ (Just c) _ SelfType = convertCpp2HS (Just c) SelfType +convertCpp2HS4Tmpl _ Nothing _ SelfType = convertCpp2HS Nothing SelfType +convertCpp2HS4Tmpl _ c _ x@(CT _ _) = convertCpp2HS c x +convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClass _) _) = convertCpp2HS c x +convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassRef _) _) = convertCpp2HS c x +convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassCopy _) _) = convertCpp2HS c x +convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassMove _) _) = convertCpp2HS c x +convertCpp2HS4Tmpl _ _ ss (TemplateApp info) = + let pss = zip (tapp_tparams info) ss + in foldl1 tyapp $ + tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _,s) -> s; (p,_) -> tycon (hsClassNameForTArg p)) pss +convertCpp2HS4Tmpl _ _ ss (TemplateAppRef info) = + let pss = zip (tapp_tparams info) ss + in foldl1 tyapp $ + tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _,s) -> s; (p,_) -> tycon (hsClassNameForTArg p)) pss +convertCpp2HS4Tmpl _ _ ss (TemplateAppMove info) = + let pss = zip (tapp_tparams info) ss + in foldl1 tyapp $ + tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _,s) -> s; (p,_) -> tycon (hsClassNameForTArg p)) pss +convertCpp2HS4Tmpl e _ _ (TemplateType _) = e +convertCpp2HS4Tmpl _ _ _ (TemplateParam p) = tySplice . parenSplice . mkVar $ p +convertCpp2HS4Tmpl _ _ _ (TemplateParamPointer p) = tySplice . parenSplice . mkVar $ p + + +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 . arg_type) 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 $ + convertCpp2HS Nothing (TemplateApp x) + (TemplateAppRef x) -> pure $ + convertCpp2HS Nothing (TemplateAppRef x) + (TemplateAppMove x)-> pure $ + convertCpp2HS Nothing (TemplateAppMove x) + (TemplateType t) -> pure $ + foldl1 tyapp (tycon (tclass_name t) : map mkTVar (tclass_params 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 + slf = foldl1 tyapp (tycon hname : map mkTVar (tclass_params t)) + ctyp = convertCpp2HS Nothing tfun_ret + lst = slf : map (convertCpp2HS Nothing . arg_type) tfun_args + in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) +functionSignatureT t TFunNew {..} = + let ctyp = convertCpp2HS Nothing (TemplateType t) + lst = map (convertCpp2HS Nothing . arg_type) 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) +functionSignatureT t TFunOp {..} = + let (hname,_) = hsTemplateClassName t + slf = foldl1 tyapp (tycon hname : map mkTVar (tclass_params t)) + ctyp = convertCpp2HS Nothing tfun_ret + lst = slf : map (convertCpp2HS Nothing . arg_type) (argsFromOpExp tfun_opexp) + in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + +-- 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 spls tfun_ret + TFunNew {..} -> convertCpp2HS4Tmpl e Nothing spls (TemplateType t) + TFunDelete -> unit_tycon + TFunOp {..} -> convertCpp2HS4Tmpl e Nothing spls tfun_ret + e = foldl1 tyapp (tycon hname : spls) + spls = map (tySplice . parenSplice . mkVar) $ tclass_params t + lst = + case f of + TFun {..} -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) tfun_args + TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spls . arg_type) tfun_new_args + TFunDelete -> [e] + TFunOp {..} -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (argsFromOpExp tfun_opexp) + +-- TODO: rename this and combine this with functionSignatureTT +functionSignatureTMF :: Class -> TemplateMemberFunction -> Type () +functionSignatureTMF c f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + where + spls = map (tySplice . parenSplice . mkVar) (tmf_params f) + ctyp = convertCpp2HS4Tmpl e Nothing spls (tmf_ret f) + e = tycon (fst (hsClassName c)) + lst = e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (tmf_args f) + + +tmplAccessorToTFun :: Variable -> Accessor -> TemplateFunction +tmplAccessorToTFun v@(Variable (Arg {..})) a = + case a of + Getter -> TFun { tfun_ret = arg_type + , tfun_name = tmplAccessorName v Getter + , tfun_oname = tmplAccessorName v Getter + , tfun_args = [] + } + Setter -> TFun { tfun_ret = Void + , tfun_name = tmplAccessorName v Setter + , tfun_oname = tmplAccessorName v Setter + , tfun_args = [Arg arg_type "value"] + } + + +accessorCFunSig :: Types -> Accessor -> CFunSig +accessorCFunSig typ Getter = CFunSig [] typ +accessorCFunSig typ Setter = CFunSig [Arg typ "x"] Void + + +accessorSignature :: Class -> Variable -> Accessor -> Type () +accessorSignature c v accessor = + let csig = accessorCFunSig (arg_type (unVariable 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 . arg_type) 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 $ + foldl1 tyapp $ + map tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateAppRef x) = tyapp tyPtr $ + foldl1 tyapp $ + map tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateAppMove x)= tyapp tyPtr $ + foldl1 tyapp $ + map tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsargtype (TemplateType t) = tyapp tyPtr $ foldl1 tyapp (tycon rawname : map mkTVar (tclass_params 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 $ + foldl1 tyapp $ + map tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateAppRef x) = tyapp tyPtr $ + foldl1 tyapp $ + map tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateAppMove x)= tyapp tyPtr $ + foldl1 tyapp $ + map tycon $ + rawname : map hsClassNameForTArg (tapp_tparams x) + where rawname = snd (hsTemplateClassName (tapp_tclass x)) + hsrettype (TemplateType t) = tyapp tyPtr $ + foldl1 tyapp (tycon rawname : map mkTVar (tclass_params 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 -> [Arg] +genericFuncArgs (Destructor _) = [] +genericFuncArgs f = func_args f diff --git a/src/FFICXX/Generate/Config.hs b/src/FFICXX/Generate/Config.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Config.hs @@ -0,0 +1,26 @@ +module FFICXX.Generate.Config where + +import FFICXX.Generate.Type.Cabal ( Cabal ) +import FFICXX.Generate.Type.Class ( Class, TopLevel ) +import FFICXX.Generate.Type.Config ( ModuleUnitMap(..) ) +import FFICXX.Generate.Type.Module ( TemplateClassImportHeader ) + + +data FFICXXConfig = FFICXXConfig { + fficxxconfig_workingDir :: FilePath + , fficxxconfig_installBaseDir :: FilePath + , fficxxconfig_staticFileDir :: FilePath + } deriving Show + +data SimpleBuilderConfig = + SimpleBuilderConfig { + sbcTopModule :: String + , sbcModUnitMap :: ModuleUnitMap + , sbcCabal :: Cabal + , sbcClasses :: [Class] + , sbcTopLevels :: [TopLevel] + , sbcTemplates :: [TemplateClassImportHeader] + , sbcExtraLibs :: [String] + , sbcExtraDeps :: [(String,[String])] + , sbcStaticFiles :: [String] + } diff --git a/src/FFICXX/Generate/ContentMaker.hs b/src/FFICXX/Generate/ContentMaker.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/ContentMaker.hs @@ -0,0 +1,531 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module FFICXX.Generate.ContentMaker where + +import Control.Lens ( (&), (.~), at ) +import Control.Monad.Trans.Reader +import Data.Either ( rights ) +import Data.Functor.Identity ( Identity ) +import qualified Data.Map as M +import Data.Maybe ( mapMaybe ) +import Data.Monoid ( (<>) ) +import Data.List ( intercalate, nub ) +import Data.List.Split ( splitOn ) +import Language.Haskell.Exts.Syntax ( Module(..) + , Decl(..) + ) +import System.FilePath ( (<.>), () ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +-- +import FFICXX.Generate.Code.Cpp ( genAllCppHeaderInclude + , genCppDefMacroAccessor + , genCppDefMacroNonVirtual + , genCppDefMacroTemplateMemberFunction + , genCppDefMacroVirtual + , genCppDefInstAccessor + , genCppDefInstNonVirtual + , genCppDefInstVirtual + , genCppHeaderInstAccessor + , genCppHeaderInstNonVirtual + , genCppHeaderInstVirtual + , genCppHeaderMacroAccessor + , genCppHeaderMacroType + , genCppHeaderMacroVirtual + , genCppHeaderMacroNonVirtual + , genTopLevelCppDefinition + , topLevelDecl + ) +import FFICXX.Generate.Code.HsCast ( genHsFrontInstCastable + , genHsFrontInstCastableSelf + ) +import FFICXX.Generate.Code.HsFFI ( genHsFFI + , genImportInFFI + , genTopLevelFFI + ) +import FFICXX.Generate.Code.HsFrontEnd ( genExport + , genExtraImport + , genHsFrontDecl + , genHsFrontDowncastClass + , genHsFrontInst + , genHsFrontInstNew + , genHsFrontInstNonVirtual + , genHsFrontInstStatic + , genHsFrontInstVariables + , genHsFrontUpcastClass + , genImportInCast + , genImportInImplementation + , genImportInInterface + , genImportInModule + , genImportInTopLevel + , genTopLevelDef + , hsClassRawType + ) +import FFICXX.Generate.Code.HsProxy ( genProxyInstance ) +import FFICXX.Generate.Code.HsTemplate ( genImportInTemplate + , genImportInTH + , genTemplateMemberFunctions + , genTmplInstance + , genTmplInterface + , genTmplImplementation + ) +import FFICXX.Generate.Dependency +import FFICXX.Generate.Name ( ffiClassName, hsClassName + , hsFrontNameForTopLevel + ) +import FFICXX.Generate.Type.Annotate ( AnnotateMap ) +import FFICXX.Generate.Type.Class ( Class(..) + , ClassGlobal(..) + , DaughterMap + , ProtectedMethod(..) + , isAbstractClass + ) +import FFICXX.Generate.Type.Module ( ClassImportHeader(..) + , ClassModule(..) + , TemplateClassImportHeader(..) + , TemplateClassModule(..) + , TopLevelImportHeader(..) + ) +import FFICXX.Generate.Type.PackageInterface ( ClassName(..) + , PackageInterface + , PackageName(..) + ) +import FFICXX.Generate.Util.HaskellSrcExts + + +srcDir :: FilePath -> FilePath +srcDir installbasedir = installbasedir "src" + +csrcDir :: FilePath -> FilePath +csrcDir installbasedir = installbasedir "csrc" + +---- common function for daughter + +-- | +mkGlobal :: [Class] -> ClassGlobal +mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap + + +-- | +buildDaughterDef :: + ((String,[Class]) -> String) + -> DaughterMap + -> String +buildDaughterDef f m = + let lst = M.toList m + f' (x,xs) = f (x,filter (not.isAbstractClass) xs) + in (concatMap f' lst) + +-- | +buildParentDef :: ((Class,Class) -> [R.CStatement Identity]) -> Class -> [R.CStatement Identity] +buildParentDef f cls = concatMap (\p -> f (p,cls)) . class_allparents $ cls + +-- | +mkProtectedFunctionList :: Class -> [R.CMacro Identity] +mkProtectedFunctionList c = + map (\x-> R.Define (R.sname ("IS_" <> class_name c <> "_" <> x <> "_PROTECTED")) [] [R.CVerbatim "()"]) + . unProtected + . class_protected + $ c + +-- | +buildTypeDeclHeader :: + [Class] + -> String +buildTypeDeclHeader classes = + let typeDeclBodyStmts = + intercalate [R.EmptyLine] $ + map (map R.CRegular . genCppHeaderMacroType) classes + in R.renderBlock $ + R.ExternC $ + [ R.Pragma R.Once, R.EmptyLine ] <> typeDeclBodyStmts + + +-- | +buildDeclHeader :: + String -- ^ C prefix + -> ClassImportHeader + -> String +buildDeclHeader cprefix header = + let classes = [cihClass header] + aclass = cihClass header + declHeaderStmts = + [ R.Include (HdrName (cprefix ++ "Type.h")) ] + <> map R.Include (cihIncludedHPkgHeadersInH header) + vdecl = map genCppHeaderMacroVirtual classes + nvdecl = map genCppHeaderMacroNonVirtual classes + acdecl = map genCppHeaderMacroAccessor classes + vdef = map genCppDefMacroVirtual classes + nvdef = map genCppDefMacroNonVirtual classes + acdef = map genCppDefMacroAccessor classes + tmpldef= map (\c -> map (genCppDefMacroTemplateMemberFunction c) (class_tmpl_funcs c)) classes + declDefStmts = + intercalate [R.EmptyLine] $ [vdecl,nvdecl,acdecl,vdef,nvdef,acdef]++tmpldef + classDeclStmts = + -- NOTE: Deletable is treated specially. + -- TODO: We had better make it as a separate constructor in Class. + if (fst.hsClassName) aclass /= "Deletable" + then buildParentDef (\(p,c) -> [genCppHeaderInstVirtual (p,c), R.CEmptyLine]) aclass + <> [genCppHeaderInstVirtual (aclass, aclass), R.CEmptyLine] + <> concatMap (\c -> [genCppHeaderInstNonVirtual c, R.CEmptyLine]) classes + <> concatMap (\c -> [genCppHeaderInstAccessor c, R.CEmptyLine]) classes + else [] + in R.renderBlock $ + R.ExternC $ + [ R.Pragma R.Once, R.EmptyLine ] + <> declHeaderStmts + <> [ R.EmptyLine ] + <> declDefStmts + <> [ R.EmptyLine ] + <> map R.CRegular classDeclStmts + +-- | +buildDefMain :: + ClassImportHeader + -> String +buildDefMain cih = + let classes = [cihClass cih] + headerStmts = + [ R.Include "MacroPatternMatch.h" ] + <> genAllCppHeaderInclude cih + <> [ R.Include (cihSelfHeader cih) ] + namespaceStmts = + (map R.UsingNamespace . 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 <> ";") + + cppBodyStmts = + mkProtectedFunctionList (cihClass cih) + <> map + R.CRegular + ( buildParentDef (\(p,c) -> [genCppDefInstVirtual (p,c), R.CEmptyLine]) (cihClass cih) + <> (if isAbstractClass aclass + then [] + else [genCppDefInstVirtual (aclass, aclass), R.CEmptyLine] + ) + <> concatMap (\c -> [genCppDefInstNonVirtual c, R.CEmptyLine]) classes + <> concatMap (\c -> [genCppDefInstAccessor c, R.CEmptyLine]) classes + ) + in concatMap R.renderCMacro + ( headerStmts + <> [ R.EmptyLine ] + <> map R.CRegular namespaceStmts + <> [ R.EmptyLine + , R.Verbatim aliasStr + , R.EmptyLine + , R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n" + , R.EmptyLine + , R.Verbatim "#define TYPECASTMETHOD(cname,mname,oname) \\\n\ + \ FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\ + \ (from_nonconst_to_nonconst), \\\n\ + \ (from_nonconst_to_nonconst) )\n" + , R.EmptyLine + ] + <> cppBodyStmts + ) + +-- | +buildTopLevelHeader :: + String -- ^ C prefix + -> TopLevelImportHeader + -> String +buildTopLevelHeader cprefix tih = + let declHeaderStmts = + [ R.Include (HdrName (cprefix ++ "Type.h")) ] + <> map R.Include (map cihSelfHeader (tihClassDep tih) ++ tihExtraHeadersInH tih) + declBodyStmts = map (R.CDeclaration . topLevelDecl) $ tihFuncs tih + in R.renderBlock $ + R.ExternC $ + [ R.Pragma R.Once, R.EmptyLine ] + <> declHeaderStmts + <> [ R.EmptyLine ] + <> map R.CRegular declBodyStmts + +-- | +buildTopLevelCppDef :: TopLevelImportHeader -> String +buildTopLevelCppDef tih = + let cihs = tihClassDep tih + extclasses = tihExtraClassDep tih + declHeaderStmts = + [ R.Include "MacroPatternMatch.h" + , R.Include (HdrName (tihHeaderFileName tih <.> "h")) + ] + <> concatMap genAllCppHeaderInclude cihs + <> otherHeaderStmts + otherHeaderStmts = + map R.Include (map cihSelfHeader cihs ++ tihExtraHeadersInCPP tih) + + allns = nub ((tihClassDep tih >>= cihNamespace) ++ tihNamespaces tih) + + namespaceStmts = map R.UsingNamespace allns + 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 = + intercalate "\n" $ + map (R.renderCStmt . genTopLevelCppDefinition) (tihFuncs tih) + + in concatMap R.renderCMacro + ( declHeaderStmts + <> [R.EmptyLine] + <> map R.CRegular namespaceStmts + <> [ R.EmptyLine + , R.Verbatim aliasStr + , R.EmptyLine + , R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n" + , R.EmptyLine + , R.Verbatim "#define TYPECASTMETHOD(cname,mname,oname) \\\n\ + \ FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\ + \ (to_nonconst), \\\n\ + \ (to_nonconst) )\n" + , R.EmptyLine + , R.Verbatim declBodyStr + ] + ) + +-- | +buildFFIHsc :: ClassModule -> Module () +buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody + where mname = cmModule m + ffiImports = [ mkImport "Data.Word" + , mkImport "Data.Int" + , mkImport "Foreign.C" + , mkImport "Foreign.Ptr" + , mkImport (mname <.> "RawType") ] + <> genImportInFFI m + <> genExtraImport m + hscBody = genHsFFI (cmCIH m) + + +-- | +buildRawTypeHs :: ClassModule -> Module () +buildRawTypeHs m = + mkModule + (cmModule m <.> "RawType") + [ lang + [ "ForeignFunctionInterface" + , "TypeFamilies" + , "MultiParamTypeClasses" + , "FlexibleInstances" + , "TypeSynonymInstances" + , "EmptyDataDecls" + , "ExistentialQuantification" + , "ScopedTypeVariables" + ] + ] + rawtypeImports + rawtypeBody + where + rawtypeImports = [ mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + ] + rawtypeBody = let c = cihClass (cmCIH m) + in if isAbstractClass c then [] else hsClassRawType c + +-- | +buildInterfaceHs :: AnnotateMap -> ClassModule -> Module () +buildInterfaceHs amap m = + mkModule + (cmModule m <.> "Interface") + [ lang + [ "EmptyDataDecls" + , "ExistentialQuantification" + , "FlexibleContexts" + , "FlexibleInstances" + , "ForeignFunctionInterface" + , "MultiParamTypeClasses" + , "ScopedTypeVariables" + , "TypeFamilies" + , "TypeSynonymInstances" + ] + ] + ifaceImports + ifaceBody + where + classes = [cihClass (cmCIH m)] + ifaceImports = [ mkImport "Data.Word" + , mkImport "Data.Int" + , mkImport "Foreign.C" + , mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + ] + <> genImportInInterface m + <> genExtraImport m + ifaceBody = + runReader (mapM genHsFrontDecl classes) amap + <> (concatMap genHsFrontUpcastClass . filter (not.isAbstractClass)) classes + <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes + +-- | +buildCastHs :: ClassModule -> Module () +buildCastHs m = mkModule (cmModule m <.> "Cast") + [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies" + , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ] + castImports body + where classes = [ cihClass (cmCIH m) ] + castImports = [ mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + , mkImport "System.IO.Unsafe" ] + <> genImportInCast m + body = mapMaybe genHsFrontInstCastable classes + <> mapMaybe genHsFrontInstCastableSelf classes + +-- | +buildImplementationHs :: AnnotateMap -> ClassModule -> Module () +buildImplementationHs amap m = + mkModule (cmModule m <.> "Implementation") + [ lang [ "EmptyDataDecls" + , "FlexibleContexts" + , "FlexibleInstances" + , "ForeignFunctionInterface" + , "IncoherentInstances" + , "MultiParamTypeClasses" + , "OverlappingInstances" + , "TemplateHaskell" + , "TypeFamilies" + , "TypeSynonymInstances" + ] + ] + implImports implBody + where + classes = [ cihClass (cmCIH m) ] + implImports = [ mkImport "Data.Monoid" -- for template member + , mkImport "Data.Word" + , mkImport "Data.Int" + , mkImport "Foreign.C" + , mkImport "Foreign.Ptr" + , 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.CodeGen.Cxx" -- for template member + , 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 + <> runReader (concat <$> mapM genHsFrontInstNew classes) amap + <> concatMap genHsFrontInstNonVirtual classes + <> concatMap genHsFrontInstStatic classes + <> concatMap genHsFrontInstVariables classes + <> genTemplateMemberFunctions (cmCIH m) + +buildProxyHs :: ClassModule -> Module () +buildProxyHs m = + mkModule (cmModule m <.> "Proxy") + [ lang [ "FlexibleInstances" + , "OverloadedStrings" + , "TemplateHaskell" + ] + ] + [ mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + , mkImport "Language.Haskell.TH" + , mkImport "Language.Haskell.TH.Syntax" + , mkImport "FFICXX.Runtime.CodeGen.Cxx" + ] + body + where + body = genProxyInstance + + + +buildTemplateHs :: TemplateClassModule -> Module () +buildTemplateHs m = + mkModule (tcmModule m <.> "Template") + [ lang + [ "EmptyDataDecls" + , "FlexibleInstances" + , "MultiParamTypeClasses" + , "TypeFamilies" + ] + ] + imports + body + where + t = tcihTClass $ tcmTCIH m + imports = [ mkImport "Foreign.C.Types" + , mkImport "Foreign.Ptr" + , mkImport "FFICXX.Runtime.Cast" + ] + <> genImportInTemplate t + body = genTmplInterface t + +buildTHHs :: TemplateClassModule -> Module () +buildTHHs m = + mkModule (tcmModule m <.> "TH") + [ lang ["TemplateHaskell"] ] + ( [ mkImport "Data.Char" + , mkImport "Data.List" + , mkImport "Data.Monoid" + , mkImport "Foreign.C.Types" + , mkImport "Foreign.Ptr" + , mkImport "Language.Haskell.TH" + , mkImport "Language.Haskell.TH.Syntax" + , mkImport "FFICXX.Runtime.CodeGen.Cxx" + , mkImport "FFICXX.Runtime.TH" + ] + <> imports + ) + body + where + t = tcihTClass $ tcmTCIH m + imports = [ mkImport (tcmModule m <.> "Template") ] + <> genImportInTH t + body = tmplImpls <> tmplInsts + tmplImpls = genTmplImplementation t + tmplInsts = genTmplInstance (tcmTCIH m) + +-- | +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) [] (genExport c) (genImportInModule c) [] + where c = cihClass (cmCIH m) + +-- | +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 . hsFrontNameForTopLevel) tfns + + pkgImports = genImportInTopLevel modname (mods,tmods) tih + + pkgBody = map (genTopLevelFFI tih) tfns + ++ concatMap genTopLevelDef tfns + +-- | +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 repo & at (pkgname,ClsName name) .~ (Just header) diff --git a/src/FFICXX/Generate/Dependency.hs b/src/FFICXX/Generate/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Dependency.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +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 ( find, foldl', nub, nubBy ) +import qualified Data.Map as M +import Data.Maybe ( catMaybes, fromMaybe, mapMaybe ) +import Data.Monoid ( (<>) ) +import System.FilePath ( (<.>) ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) +-- +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 ( Arg(..) + , Class(..) + , CPPTypes(..) + , DaughterMap + , Function(..) + , TemplateAppInfo(..) + , TemplateArgType(TArg_Class) + , TemplateClass(..) + , TemplateFunction(..) + , TemplateMemberFunction(..) + , TopLevel(..) + , Types(..) + , Variable(unVariable) + , argsFromOpExp + ) +import FFICXX.Generate.Type.Config ( ModuleUnit(..) + , ModuleUnitImports(..) + , emptyModuleUnitImports + , ModuleUnitMap(..) + ) +import FFICXX.Generate.Type.Module ( ClassImportHeader(..) + , ClassModule(..) + , PackageConfig(..) + , TemplateClassImportHeader(..) + , TemplateClassModule(..) + , TopLevelImportHeader(..) + ) + + +-- 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 ps _)) = + Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps) +extractClassFromType (TemplateAppRef (TemplateAppInfo t ps _)) = + Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps) +extractClassFromType (TemplateAppMove (TemplateAppInfo t ps _)) = + Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps) +extractClassFromType (TemplateType t) = [Left t] +extractClassFromType (TemplateParam _) = [] +extractClassFromType (TemplateParamPointer _) = [] + +classFromArg :: Arg -> [Either TemplateClass Class] +classFromArg = extractClassFromType . arg_type + + +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 classFromArg args) +extractClassDep (Virtual ret _ args _) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) +extractClassDep (NonVirtual ret _ args _) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) +extractClassDep (Static ret _ args _) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) +extractClassDep (Destructor _) = + Dep4Func [] [] + +-- | +extractClassDepForTmplFun :: TemplateFunction -> Dep4Func +extractClassDepForTmplFun (TFun ret _ _ args) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) +extractClassDepForTmplFun (TFunNew args _) = + Dep4Func [] (concatMap classFromArg args) +extractClassDepForTmplFun TFunDelete = + Dep4Func [] [] +extractClassDepForTmplFun (TFunOp ret _ e) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e) + +-- | +extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func +extractClassDep4TmplMemberFun (TemplateMemberFunction {..}) = + Dep4Func (extractClassFromType tmf_ret) (concatMap classFromArg tmf_args) + +-- | +extractClassDepForTopLevel :: TopLevel -> Dep4Func +extractClassDepForTopLevel f = + Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) 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 (classFromArg . unVariable) 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 (classFromArg . unVariable) 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 + , cmCIH = 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 :: + TemplateClassImportHeader + -> TemplateClassModule +mkTCM tcih = + let t = tcihTClass tcih + in TCM (getTClassModuleBase t) tcih + +-- | +mkPackageConfig + :: (CabalName, ModuleUnit -> ModuleUnitImports) -- ^ (package name,getImports) + -> ([Class],[TopLevel],[TemplateClassImportHeader],[(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 (map cmCIH ms) + -- + tih = mkTIH pkgname getImports cihs fs + tcms = map mkTCM ts + tcihs = map 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] + -> [TopLevel] + -> TopLevelImportHeader +mkTIH pkgname getImports cihs fs = + let tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevel) fs + tl_cs2 = concatMap (returnDependency . extractClassDepForTopLevel) 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/src/FFICXX/Generate/Name.hs b/src/FFICXX/Generate/Name.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Name.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE RecordWildCards #-} +module FFICXX.Generate.Name where + +import Data.Char ( toLower ) +import Data.Maybe ( fromMaybe, maybe ) +import Data.Monoid ( (<>) ) +-- +import FFICXX.Generate.Type.Class ( Accessor(..) + , Arg(..) + , Class(..) + , ClassAlias(caHaskellName,caFFIName) + , Function(..) + , TemplateArgType(..) + , TemplateClass(..) + , TemplateFunction(..) + , TemplateMemberFunction(..) + , TopLevel(..) + , Variable(..) + ) +import FFICXX.Generate.Util ( firstLower, toLowers ) + + + +hsFrontNameForTopLevel :: TopLevel -> String +hsFrontNameForTopLevel 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 + TFunNew {..} -> fromMaybe ("new"<> tclass_name t) tfun_new_alias + TFunDelete -> "delete" <> tclass_name t + TFunOp {..} -> tfun_name + +-- | +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) + + +hsTemplateMemberFunctionNameTH :: Class -> TemplateMemberFunction -> String +hsTemplateMemberFunctionNameTH c f = "t_" <> hsTemplateMemberFunctionName c f + + +ffiTmplFuncName :: TemplateFunction -> String +ffiTmplFuncName f = + case f of + TFun {..} -> tfun_name + TFunNew {..} -> fromMaybe "new" tfun_new_alias + TFunDelete -> "delete" + TFunOp {..} -> tfun_name + +cppTmplFuncName :: TemplateFunction -> String +cppTmplFuncName f = + case f of + TFun {..} -> tfun_name + TFunNew {..} -> "new" + TFunDelete -> "delete" + TFunOp {..} -> tfun_name + +-- | +accessorName :: Class -> Variable -> Accessor -> String +accessorName c v a = nonvirtualName c (arg_name (unVariable v)) + <> "_" + <> case a of + Getter -> "get" + Setter -> "set" + +-- | +hscAccessorName :: Class -> Variable -> Accessor -> String +hscAccessorName c v a = "c_" <> toLowers (accessorName c v a) + +-- | +tmplAccessorName :: Variable -> Accessor -> String +tmplAccessorName (Variable (Arg _ n)) a = + n <> "_" <> case a of { Getter -> "get"; Setter -> "set" } + +-- | +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/src/FFICXX/Generate/QQ/Verbatim.hs b/src/FFICXX/Generate/QQ/Verbatim.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/QQ/Verbatim.hs @@ -0,0 +1,13 @@ +module FFICXX.Generate.QQ.Verbatim where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Lib + +verbatim :: QuasiQuoter +verbatim = QuasiQuoter{ quoteExp = litE . stringL + , quotePat = undefined + , quoteType = undefined + , quoteDec = undefined + -- , quotePat = litP . stringP + } + diff --git a/src/FFICXX/Generate/Type/Annotate.hs b/src/FFICXX/Generate/Type/Annotate.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Type/Annotate.hs @@ -0,0 +1,11 @@ +module FFICXX.Generate.Type.Annotate where + +import qualified Data.Map as M + +data PkgType = PkgModule | PkgClass | PkgMethod + deriving (Show,Eq,Ord) + +type AnnotateMap = M.Map (PkgType,String) String + + + diff --git a/src/FFICXX/Generate/Type/Cabal.hs b/src/FFICXX/Generate/Type/Cabal.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Type/Cabal.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveGeneric #-} + +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) + + +data BuildType = Simple + | Custom [CabalName] -- ^ dependencies + +-- 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] + , cabal_buildType :: BuildType + } + +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_cxxOptions :: [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/src/FFICXX/Generate/Type/Class.hs b/src/FFICXX/Generate/Type/Class.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Type/Class.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Type.Class where + +import Data.List ( intercalate ) +import qualified Data.Map as M +import Data.Monoid ( Monoid(..) ) +import Data.Semigroup ( Semigroup(..), (<>) ) +-- +import FFICXX.Generate.Type.Cabal ( Cabal ) + + +-- | C types +data CTypes = + CTBool + | CTChar + | CTClock + | CTDouble + | CTFile + | CTFloat + | CTFpos + | CTInt + | CTIntMax + | CTIntPtr + | CTJmpBuf + | CTLLong + | CTLong + | CTPtrdiff + | CTSChar + | CTSUSeconds + | CTShort + | CTSigAtomic + | CTSize + | CTTime + | CTUChar + | CTUInt + | CTUIntMax + | CTUIntPtr + | CTULLong + | CTULong + | CTUSeconds + | CTUShort + | CTWchar + | CTInt8 + | CTInt16 + | CTInt32 + | CTInt64 + | CTUInt8 + | CTUInt16 + | CTUInt32 + | CTUInt64 + | CTVoidStar + | CTString + | CEnum CTypes String + | CPointer CTypes + | CRef CTypes + deriving Show + +-- | C++ types +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_tparams :: [TemplateArgType] + , tapp_CppTypeForParam :: String -- TODO: remove this + } + deriving Show + +-- | Supported C++ types. +data Types = + Void + | SelfType + | CT CTypes IsConst + | CPT CPPTypes IsConst + | 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 + +------------- + +-- | Function argument, type and variable name. +data Arg = + Arg { + arg_type :: Types + , arg_name :: String + } + deriving Show + +-- | Regular member functions in a ordinary class +data Function = + Constructor { + func_args :: [Arg] + , func_alias :: Maybe String + } + | Virtual { + func_ret :: Types + , func_name :: String + , func_args :: [Arg] + , func_alias :: Maybe String + } + | NonVirtual { + func_ret :: Types + , func_name :: String + , func_args :: [Arg] + , func_alias :: Maybe String + } + | Static { + func_ret :: Types + , func_name :: String + , func_args :: [Arg] + , func_alias :: Maybe String + } + | Destructor { + func_alias :: Maybe String + } + deriving Show + +-- | Member variable. Isomorphic to Arg +newtype Variable = + Variable { unVariable :: Arg } + deriving Show + +-- | Member functions of a template class. +data TemplateMemberFunction = + TemplateMemberFunction { + tmf_params :: [String] + , tmf_ret :: Types + , tmf_name :: String + , tmf_args :: [Arg] + , tmf_alias :: Maybe String + } + deriving Show + +-- | Function defined at top level like ordinary C functions, +-- i.e. no owning class. +data TopLevel = + TopLevelFunction { + toplevelfunc_ret :: Types + , toplevelfunc_name :: String + , toplevelfunc_args :: [Arg] + , toplevelfunc_alias :: Maybe String + } + | TopLevelVariable { + toplevelvar_ret :: Types + , toplevelvar_name :: String + , toplevelvar_alias :: Maybe String + } + deriving Show + +isNewFunc :: Function -> Bool +isNewFunc (Constructor _ _) = True +isNewFunc _ = False + +isDeleteFunc :: Function -> Bool +isDeleteFunc (Destructor _) = True +isDeleteFunc _ = False + +isVirtualFunc :: Function -> Bool +isVirtualFunc (Destructor _) = True +isVirtualFunc (Virtual _ _ _ _) = True +isVirtualFunc _ = False + +isNonVirtualFunc :: Function -> Bool +isNonVirtualFunc (NonVirtual _ _ _ _) = True +isNonVirtualFunc _ = False + + + +isStaticFunc :: Function -> Bool +isStaticFunc (Static _ _ _ _) = True +isStaticFunc _ = False + +virtualFuncs :: [Function] -> [Function] +virtualFuncs = filter isVirtualFunc + +constructorFuncs :: [Function] -> [Function] +constructorFuncs = filter isNewFunc + +nonVirtualNotNewFuncs :: [Function] -> [Function] +nonVirtualNotNewFuncs = + filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x ) + +staticFuncs :: [Function] -> [Function] +staticFuncs = filter isStaticFunc + +-------- + +newtype ProtectedMethod = Protected { unProtected :: [String] } + deriving (Semigroup, Monoid) + +data ClassAlias = ClassAlias { caHaskellName :: String + , caFFIName :: String + } + +-- 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] + , class_has_proxy :: Bool + } + | 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) + +data OpExp = OpStar -- ^ unary * (deRef) operator + | OpFPPlus -- ^ unary prefix ++ operator + -- | OpAdd Arg Arg + -- | OpMul Arg Arg + +data TemplateFunction = + TFun { + tfun_ret :: Types + , tfun_name :: String + , tfun_oname :: String + , tfun_args :: [Arg] + } + | TFunNew { + tfun_new_args :: [Arg] + , tfun_new_alias :: Maybe String + } + | TFunDelete + | TFunOp { + tfun_ret :: Types + , tfun_name :: String -- ^ haskell alias for the operator + , tfun_opexp :: OpExp + } + +argsFromOpExp :: OpExp -> [Arg] +argsFromOpExp OpStar = [] +argsFromOpExp OpFPPlus = [] +-- argsFromOpExp (OpAdd x y) = [x,y] +-- argsFromOpExp (OpMul x y) = [x,y] + +opSymbol :: OpExp -> String +opSymbol OpStar = "*" +opSymbol OpFPPlus = "++" +-- opSymbol (OpAdd _ _) = "+" +-- opSymbol (OpMul _ _) = "*" + +-- TODO: Generalize this further. +-- | Positional string interpolation form. +-- For example, "std::map::iterator" is FormNested "std::map" "iterator"]. +data Form = FormSimple String + | FormNested String String + +data TemplateClass = + TmplCls { + tclass_cabal :: Cabal + , tclass_name :: String + , tclass_cxxform :: Form + , tclass_params :: [String] + , tclass_funcs :: [TemplateFunction] + , tclass_vars :: [Variable] + } + +-- TODO: we had better not override standard definitions +instance Show TemplateClass where + show x = show (tclass_name x <> " " <> intercalate " " (tclass_params 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) + + +data ClassGlobal = ClassGlobal + { cgDaughterSelfMap :: DaughterMap + , cgDaughterMap :: DaughterMap + } + +data Selfness = Self | NoSelf + + + +-- | Check abstract class +isAbstractClass :: Class -> Bool +isAbstractClass Class{} = False +isAbstractClass AbstractClass{} = True + +-- | Check having Proxy +hasProxy :: Class -> Bool +hasProxy c@Class{} = class_has_proxy c +hasProxy AbstractClass{} = False + +type DaughterMap = M.Map String [Class] + +data Accessor = Getter | Setter + deriving (Show, Eq) diff --git a/src/FFICXX/Generate/Type/Config.hs b/src/FFICXX/Generate/Type/Config.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Type/Config.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DeriveGeneric #-} +module FFICXX.Generate.Type.Config where + +import Data.Hashable ( Hashable(..) ) +import Data.HashMap.Strict ( HashMap ) +import GHC.Generics ( Generic ) +-- +import FFICXX.Runtime.CodeGen.Cxx ( 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 } + +modImports :: + String + -> [String] + -> [HeaderName] + -> (ModuleUnit,ModuleUnitImports) +modImports n ns hs = + ( MU_Class n + , ModuleUnitImports { + muimports_namespaces = map NS ns + , muimports_headers = hs + } + ) diff --git a/src/FFICXX/Generate/Type/Module.hs b/src/FFICXX/Generate/Type/Module.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Type/Module.hs @@ -0,0 +1,80 @@ +module FFICXX.Generate.Type.Module where + +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..), Namespace(..) ) +-- +import FFICXX.Generate.Type.Cabal ( AddCInc, AddCSrc ) +import FFICXX.Generate.Type.Class ( Class, TemplateClass, TopLevel ) + + +-- | C++ side +-- HPkg is generated C++ headers by fficxx, CPkg is original C++ headers +data ClassImportHeader = + ClassImportHeader { + cihClass :: Class + , cihSelfHeader :: HeaderName -- ^ fficxx-side main header + , cihNamespace :: [Namespace] + , cihSelfCpp :: String + , cihImportedClasses :: [Either TemplateClass Class] -- ^ Dependencies TODO: clarify this. + , cihIncludedHPkgHeadersInH :: [HeaderName] -- TODO: Explain why we need to have these two + , cihIncludedHPkgHeadersInCPP :: [HeaderName] -- separately. + , cihIncludedCPkgHeaders :: [HeaderName] -- ^ C++-side headers + } deriving (Show) + + +------------------------- +-- Haskell side module -- +------------------------- + +data ClassModule = + ClassModule { + cmModule :: String + , cmCIH :: ClassImportHeader + , 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) + + +data TemplateClassModule = + TCM { + tcmModule :: String + , tcmTCIH :: TemplateClassImportHeader + } deriving (Show) + + +data TemplateClassImportHeader = + TCIH { + tcihTClass :: TemplateClass + , tcihCxxHeaders :: [HeaderName] -- ^ C++-side headers + } 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 :: [TopLevel] + , tihNamespaces :: [Namespace] + , tihExtraHeadersInH :: [HeaderName] + , tihExtraHeadersInCPP :: [HeaderName] + } deriving (Show) + +data PackageConfig = + PkgConfig { + pcfg_classModules :: [ClassModule] + , pcfg_classImportHeaders :: [ClassImportHeader] + , pcfg_topLevelImportHeader :: TopLevelImportHeader + , pcfg_templateClassModules :: [TemplateClassModule] + , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader] + , pcfg_additional_c_incs :: [AddCInc] + , pcfg_additional_c_srcs :: [AddCSrc] + } diff --git a/src/FFICXX/Generate/Type/PackageInterface.hs b/src/FFICXX/Generate/Type/PackageInterface.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Type/PackageInterface.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- TODO: remove this module +module FFICXX.Generate.Type.PackageInterface where + +import Data.Hashable ( Hashable ) +import qualified Data.HashMap.Strict as HM +-- +import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) + + +newtype PackageName = PkgName String deriving (Hashable, Show, Eq, Ord) +newtype ClassName = ClsName String deriving (Hashable, Show, Eq, Ord) + +type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName diff --git a/src/FFICXX/Generate/Util.hs b/src/FFICXX/Generate/Util.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Util.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FFICXX.Generate.Util where + +import Data.Char +import Data.List +import Data.List.Split +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 +-- + +moduleDirFile :: String -> (String,String) +moduleDirFile mname = + let splitted = splitOn "." mname + moddir = intercalate "/" (init splitted ) + modfile = (last splitted) <> ".hs" + in (moddir, modfile) + +hline :: IO () +hline = putStrLn "--------------------------------------------------------" + +toUppers :: String -> String +toUppers = map toUpper + +toLowers :: String -> String +toLowers = map toLower + + +firstLower :: String -> String +firstLower [] = [] +firstLower (x:xs) = (toLower x) : xs + +conn :: String -> String -> String -> String +conn st x y = x <> st <> y + +connspace :: String -> String -> String +connspace = conn " " + +conncomma :: String -> String -> String +conncomma = conn ", " + +connBSlash :: String -> String -> String +connBSlash = conn "\\\n" + +connSemicolonBSlash :: String -> String -> String +connSemicolonBSlash = conn "; \\\n" + +connRet :: String -> String -> String +connRet = conn "\n" + +connRet2 :: String -> String -> String +connRet2 = conn "\n\n" + +connArrow :: String -> String -> String +connArrow = conn " -> " + +intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String +intercalateWith f mapper x + | not (null x) = foldl1 f (map mapper x) + | otherwise = "" + + +intercalateWithM :: (Monad m) => (String -> String -> String) -> (a->m String) -> [a] -> m String +intercalateWithM f mapper x + | not (null x) = do ms <- mapM mapper x + return (foldl1 f ms) + | 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/src/FFICXX/Generate/Util/HaskellSrcExts.hs b/src/FFICXX/Generate/Util/HaskellSrcExts.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Util/HaskellSrcExts.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE CPP #-} + +module FFICXX.Generate.Util.HaskellSrcExts where + +import Data.Maybe (maybeToList) +import Data.List (foldl') +import Language.Haskell.Exts hiding (unit_tycon) +import qualified Language.Haskell.Exts (unit_tycon) + + +unqual :: String -> QName () +unqual = UnQual () . Ident () + +tycon :: String -> Type () +tycon = TyCon () . unqual + +tyapp :: Type () -> Type () -> Type () +tyapp = TyApp () + +infixl 2 `tyapp` + +tyfun :: Type () -> Type () -> Type () +tyfun = TyFun () + +infixr 2 `tyfun` + +tylist :: Type () -> Type () +tylist = TyList () + +unit_tycon :: Type () +unit_tycon = Language.Haskell.Exts.unit_tycon () + +conDecl :: String -> [Type ()] -> ConDecl () +conDecl n ys = ConDecl () (Ident () n) ys + +qualConDecl = QualConDecl () + +recDecl :: String -> [FieldDecl ()] -> ConDecl () +recDecl n rs = RecDecl () (Ident () n) rs + +app' :: String -> String -> Exp () +app' x y = App () (mkVar x) (mkVar y) + + +lit :: Literal () -> Exp () +lit = Lit () + + +mkVar :: String -> Exp () +mkVar = Var () . unqual + +con :: String -> Exp () +con = Con () . unqual + +mkTVar :: String -> Type () +mkTVar = TyVar () . Ident () + +mkPVar :: String -> Pat () +mkPVar = PVar () . Ident () + +mkIVar :: String -> ImportSpec () +mkIVar = IVar () . Ident () + +mkPVarSig :: String -> Type () -> Pat () +mkPVarSig n typ = PatTypeSig () (mkPVar n) typ + +pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl () +pbind pat e = PatBind () pat (UnGuardedRhs () e) + +pbind_ :: Pat () -> Exp () -> Decl () +pbind_ p e = pbind p e Nothing + +mkTBind :: String -> TyVarBind () +mkTBind = UnkindedVar () . Ident () + +mkBind1 :: String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl () +mkBind1 n pat rhs mbinds = + FunBind () [ Match () (Ident () n) pat (UnGuardedRhs () rhs) mbinds ] + +mkFun :: String -> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()] +mkFun fname typ pats rhs mbinds = [mkFunSig fname typ, mkBind1 fname pats rhs mbinds] + +mkFunSig :: String -> Type () -> Decl () +mkFunSig fname typ = TypeSig () [Ident () fname] typ + +mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl () +mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just cdecls) + + +dhead :: String -> DeclHead () +dhead n = DHead () (Ident () n) + +mkDeclHead :: String -> [TyVarBind ()] -> DeclHead () +mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds + +mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl () +mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls) + where instrule = IRule () Nothing (Just ctxt) insthead + insthead = foldl' f (IHCon () (unqual n)) typs + where f acc x = IHApp () acc (tyParen x) + +mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () +#if MIN_VERSION_haskell_src_exts(1,20,0) +mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) +#else +mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls mderiv +#endif + where declhead = mkDeclHead n tbinds + +mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl () +#if MIN_VERSION_haskell_src_exts(1,20,0) +mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv) +#else +mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls mderiv +#endif + where declhead = mkDeclHead n tbinds + +mkForImpCcall :: String -> String -> Type () -> Decl () +mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlaySafe () False)) (Just quote) (Ident () n) typ + +mkModule :: String -> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module () +mkModule n pragmas idecls decls = Module () (Just mhead) pragmas idecls decls + where mhead = ModuleHead () (ModuleName () n) Nothing Nothing + +mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module () +mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls + where mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist) + eslist = ExportSpecList () exps + +mkImport :: String -> ImportDecl () +mkImport m = ImportDecl () (ModuleName () m) False False False Nothing Nothing Nothing + +mkImportExp :: String -> [String] -> ImportDecl () +mkImportExp m lst = + ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) + where islist = ImportSpecList () False (map mkIVar lst) + + +mkImportSrc :: String -> ImportDecl () +mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing + +lang :: [String] -> ModulePragma () +lang ns = LanguagePragma () (map (Ident ()) ns) + +dot :: Exp () -> Exp () -> Exp () +x `dot` y = x `app` mkVar "." `app` y + +tyForall = TyForall () + +tyParen = TyParen () + +tyPtr :: Type () +tyPtr = tycon "Ptr" + +tyForeignPtr :: Type () +tyForeignPtr = tycon "ForeignPtr" + +classA :: QName () -> [Type ()] -> Asst () +#if MIN_VERSION_haskell_src_exts(1,22,0) +classA n = TypeA () . foldl' tyapp (TyCon () n) +#else +classA = ClassA () +#endif + +cxEmpty :: Context () +cxEmpty = CxEmpty () + +cxTuple :: [Asst ()] -> Context () +cxTuple = CxTuple () + +tySplice :: Splice () -> Type () +tySplice = TySplice () + +parenSplice :: Exp () -> Splice () +parenSplice = ParenSplice () + +bracketExp = BracketExp () +typeBracket = TypeBracket () + + +#if MIN_VERSION_haskell_src_exts(1,20,0) +mkDeriving = Deriving () Nothing +#else +mkDeriving = Deriving () +#endif + +irule = IRule () + +ihcon = IHCon () + +evar = EVar () +eabs = EAbs () +ethingwith = EThingWith () + +ethingall q = ethingwith (EWildcard () 0) q [] + +emodule nm = EModuleContents () (ModuleName () nm) + +nonamespace = NoNamespace () + +insType = InsType () + +insDecl = InsDecl () + +generator = Generator () + +qualifier = Qualifier () + +clsDecl = ClsDecl () + + +unkindedVar = UnkindedVar () + +op = QVarOp () . UnQual () . Symbol () + +inapp = InfixApp () + +if_ = If () + +urhs = UnGuardedRhs () + +-- case pattern match p -> e +match p e = Alt () p (urhs e) Nothing