diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,62 @@ +# Changelog for fficxx + +## 0.7.0.0 + +- Show generated module dependency graph (#203) +- Fix incorrect hs-boot (#199) +- Simplify Nix script and support for multiple GHC versions in build (#196) +- aarch64-darwin support (#195) +- Implicit imports cleanup (#193) +- Upgrade to NixOS 21.11. (#192) +- CI action for ormolu formatting (#190) +- github action CI with nix build targets (#189) +- format all Haskell files by ormolu 0.0.3 (#180) + + +## 0.6 + +- no more impure (#178) +- Duplicated template instances are safe (#176) +- Update for haskell-src-exts >= 1.22 (#174) +- change to_const/to_nonconst to from_X_to_Y (#172) +- std::map::iterator is now supported. (#168) +- accessor for member variables of C++ template (#167) +- Support nested types inside template class (#163) +- Automatic dependency import in template class module (#162) +- cabal package generation and testing using hspec (#159) +- fficxx-test: stdcxx tests are rewritten as hspec tests (#158) +- multi-parameter template for function arguments and template member functions (#156) +- C++ multi-parameter template interfaced via fficxx! (#154) +- one class or template class per one haskell module! (#151) +- Inline C++ code generation for template member function (#149) +- Inline C++ code generation for std::function (#148) +- CDefinition. Unified newline treatment in Macro definition (#143) +- More ASTification with CMacroApp (#141) +- Declaration generation uses intermediate pseudo-AST representation (#140) +- Further towards intermediate reps for C++ code generation (#139) +- Further removing #include and using namespace (#138) +- Start C intermediate rep (#137) +- Convert (Types,String) to Arg (#134) +- no more stub.cc (#132) + +## 0.5.1 + +## 0.5.0.1 + +## 0.5 + +## 0.4.1 + +## 0.4 + +## 0.3.1 + +## 0.3 + +## 0.2.1 + +## 0.2 + +## 0.1.0 + +## 0.1 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-2019, Ian-Woo Kim. All rights reserved. +Copyright 2011-2022, 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/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -1,14 +1,17 @@ +Cabal-Version: 3.0 Name: fficxx -Version: 0.6 +Version: 0.7.0.0 Synopsis: Automatic C++ binding generation Description: fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++. -License: BSD3 +License: BSD-2-Clause License-file: LICENSE Author: Ian-Woo Kim Maintainer: Ian-Woo Kim Build-Type: Simple +Tested-With: GHC == 9.0.2 || == 9.2.4 || == 9.4.2 Category: FFI Tools -Cabal-Version: >= 1.10 +Extra-Source-Files: + ChangeLog.md Source-repository head type: git @@ -16,21 +19,22 @@ Library hs-source-dirs: src - default-language: Haskell2010 + default-language: Haskell2010 Build-Depends: base == 4.* , aeson , aeson-pretty + , array , bytestring , Cabal , containers , data-default , directory - , either + , dotgen , errors , fficxx-runtime , filepath>1 , hashable - , haskell-src-exts >= 1.18 + , haskell-src-exts >= 1.22 , lens > 3 , mtl>2 , process @@ -54,9 +58,11 @@ FFICXX.Generate.Code.Primitive FFICXX.Generate.ContentMaker FFICXX.Generate.Dependency + FFICXX.Generate.Dependency.Graph FFICXX.Generate.Name FFICXX.Generate.QQ.Verbatim FFICXX.Generate.Util + FFICXX.Generate.Util.DepGraph FFICXX.Generate.Util.HaskellSrcExts FFICXX.Generate.Type.Annotate FFICXX.Generate.Type.Cabal diff --git a/src/FFICXX/Generate/Builder.hs b/src/FFICXX/Generate/Builder.hs --- a/src/FFICXX/Generate/Builder.hs +++ b/src/FFICXX/Generate/Builder.hs @@ -3,52 +3,56 @@ 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 ) --- +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 qualified Data.Text as T +import FFICXX.Generate.Code.Cabal (buildCabalFile, buildJSONFile) +import FFICXX.Generate.Config + ( FFICXXConfig (..), + SimpleBuilderConfig (..), + ) +import qualified FFICXX.Generate.ContentMaker as C +import FFICXX.Generate.Dependency + ( findModuleUnitImports, + mkPackageConfig, + ) +import FFICXX.Generate.Dependency.Graph + ( constructDepGraph, + findDepCycles, + gatherHsBootSubmodules, + ) +import FFICXX.Generate.Type.Cabal + ( AddCInc (..), + AddCSrc (..), + Cabal (..), + CabalName (..), + ) +import FFICXX.Generate.Type.Class (hasProxy) +import FFICXX.Generate.Type.Module + ( ClassImportHeader (..), + ClassModule (..), + PackageConfig (..), + TemplateClassImportHeader (..), + TemplateClassModule (..), + TopLevelImportHeader (..), + ) +import FFICXX.Generate.Util (moduleDirFile) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import Language.Haskell.Exts.Pretty (prettyPrint) +import System.Directory + ( copyFile, + createDirectoryIfMissing, + doesFileExist, + ) +import System.FilePath (splitExtension, (<.>), ()) +import System.IO (IOMode (..), hPutStrLn, withFile) +import System.Process (readProcess) macrofy :: String -> String -macrofy = map ((\x->if x=='-' then '_' else x) . toUpper) - +macrofy = map ((\x -> if x == '-' then '_' else x) . toUpper) simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO () simpleBuilder cfg sbc = do @@ -63,24 +67,35 @@ toplevelfunctions templates extralibs + cxxopts extramods - staticFiles - = sbc + staticFiles = + sbc pkgname = cabal_pkgname cabal putStrLn ("Generating " <> unCabalName pkgname) let workingDir = fficxxconfig_workingDir cfg installDir = fficxxconfig_installBaseDir cfg - staticDir = fficxxconfig_staticFileDir cfg - + staticDir = fficxxconfig_staticFileDir cfg pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) = mkPackageConfig (pkgname, findModuleUnitImports mumap) - (classes, toplevelfunctions,templates,extramods) + (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" + allClasses = fmap (Left . tcihTClass) templates ++ fmap Right classes + depCycles = + findDepCycles $ + constructDepGraph allClasses toplevelfunctions + -- for now, put this function here + -- This function is a little ad hoc, only for Interface.hs. + -- But as of now, we support hs-boot for ordinary class only. + mkHsBootCandidateList :: [ClassModule] -> [ClassModule] + mkHsBootCandidateList ms = + let hsbootSubmods = gatherHsBootSubmodules depCycles + in filter (\c -> cmModule c <.> "Interface" `elem` hsbootSubmods) ms + hsbootlst = mkHsBootCandidateList mods -- createDirectoryIfMissing True workingDir createDirectoryIfMissing True installDir @@ -88,114 +103,137 @@ createDirectoryIfMissing True (installDir "csrc") -- putStrLn "Copying static files" - mapM_ (\x->copyFileWithMD5Check (staticDir x) (installDir x)) staticFiles + mapM_ (\x -> copyFileWithMD5Check (staticDir x) (installDir x)) staticFiles -- putStrLn "Generating Cabal file" - buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDircabalFileName) + buildCabalFile cabal topLevelMod pkgconfig extralibs cxxopts (workingDir cabalFileName) -- putStrLn "Generating JSON file" - buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDirjsonFileName) + buildJSONFile cabal topLevelMod pkgconfig extralibs cxxopts (workingDir jsonFileName) -- putStrLn "Generating Header file" - let - gen :: FilePath -> String -> IO () + 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 (unCabalName pkgname <> "Type.h") (C.buildTypeDeclHeader (map cihClass cihs)) + for_ cihs $ \hdr -> + gen + (unHdrName (cihSelfHeader hdr)) + (C.buildDeclHeader (unCabalName pkgname) hdr) gen (tihHeaderFileName tih <.> "h") - (buildTopLevelHeader (unCabalName pkgname) tih) - + (C.buildTopLevelHeader (unCabalName pkgname) tih) putStrLn "Generating Cpp file" - for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) - gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih) + for_ cihs (\hdr -> gen (cihSelfCpp hdr) (C.buildDefMain hdr)) + gen (tihHeaderFileName tih <.> "cpp") (C.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)) + for_ mods $ \m -> + gen + (cmModule m <.> "RawType" <.> "hs") + (prettyPrint (C.buildRawTypeHs m)) -- putStrLn "Generating FFI.hsc" - for_ mods $ \m -> gen - (cmModule m <.> "FFI" <.> "hsc") - (prettyPrint (buildFFIHsc m)) + for_ mods $ \m -> + gen + (cmModule m <.> "FFI" <.> "hsc") + (prettyPrint (C.buildFFIHsc m)) -- putStrLn "Generating Interface.hs" - for_ mods $ \m -> gen - (cmModule m <.> "Interface" <.> "hs") - (prettyPrint (buildInterfaceHs mempty m)) + for_ mods $ \m -> + gen + (cmModule m <.> "Interface" <.> "hs") + (prettyPrint (C.buildInterfaceHs mempty depCycles m)) -- putStrLn "Generating Cast.hs" - for_ mods $ \m -> gen - (cmModule m <.> "Cast" <.> "hs") - (prettyPrint (buildCastHs m)) + for_ mods $ \m -> + gen + (cmModule m <.> "Cast" <.> "hs") + (prettyPrint (C.buildCastHs m)) -- putStrLn "Generating Implementation.hs" - for_ mods $ \m -> gen - (cmModule m <.> "Implementation" <.> "hs") - (prettyPrint (buildImplementationHs mempty m)) - -- + for_ mods $ \m -> + gen + (cmModule m <.> "Implementation" <.> "hs") + (prettyPrint (C.buildImplementationHs mempty m)) + -- putStrLn "Generating Proxy.hs" for_ mods $ \m -> when (hasProxy . cihClass . cmCIH $ m) $ - gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (buildProxyHs m)) + gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (C.buildProxyHs m)) -- putStrLn "Generating Template.hs" - for_ tcms $ \m -> gen - (tcmModule m <.> "Template" <.> "hs") - (prettyPrint (buildTemplateHs m)) + for_ tcms $ \m -> + gen + (tcmModule m <.> "Template" <.> "hs") + (prettyPrint (C.buildTemplateHs m)) -- putStrLn "Generating TH.hs" - for_ tcms $ \m -> gen - (tcmModule m <.> "TH" <.> "hs") - (prettyPrint (buildTHHs m)) - + for_ tcms $ \m -> + gen + (tcmModule m <.> "TH" <.> "hs") + (prettyPrint (C.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)) + -- This is a hack since haskell-src-exts always codegen () => instead of empty + -- string for an empty context, which have different meanings in hs-boot file. + -- Therefore, we get rid of them. + let hsBootHackClearEmptyContexts = T.unpack . T.replace "() =>" "" . T.pack + for_ hsbootlst $ \m -> do + gen + (cmModule m <.> "Interface" <.> "hs-boot") + (hsBootHackClearEmptyContexts $ prettyPrint (C.buildInterfaceHsBoot depCycles m)) -- putStrLn "Generating Module summary file" - for_ mods $ \m -> gen - (cmModule m <.> "hs") - (prettyPrint (buildModuleHs m)) + for_ mods $ \m -> + gen + (cmModule m <.> "hs") + (prettyPrint (C.buildModuleHs m)) -- + putStrLn "Generating Top-level Ordinary Module" + gen (topLevelMod <.> "Ordinary" <.> "hs") (prettyPrint (C.buildTopLevelOrdinaryHs (topLevelMod <> ".Ordinary") (mods, tcms) tih)) + -- + putStrLn "Generating Top-level Template Module" + gen + (topLevelMod <.> "Template" <.> "hs") + (prettyPrint (C.buildTopLevelTemplateHs (topLevelMod <> ".Template") tih)) + -- + putStrLn "Generating Top-level TH Module" + gen + (topLevelMod <.> "TH" <.> "hs") + (prettyPrint (C.buildTopLevelTHHs (topLevelMod <> ".TH") tih)) + -- putStrLn "Generating Top-level Module" - gen (topLevelMod <.> "hs") (prettyPrint (buildTopLevelHs topLevelMod (mods,tcms) tih)) + gen + (topLevelMod <.> "hs") + (prettyPrint (C.buildTopLevelHs topLevelMod (mods, tcms))) -- putStrLn "Copying generated files to target directory" touch (workingDir "LICENSE") - copyFileWithMD5Check (workingDir cabalFileName) (installDir cabalFileName) - copyFileWithMD5Check (workingDir jsonFileName) (installDir jsonFileName) + 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" - + copyCppFiles workingDir (C.csrcDir installDir) (unCabalName pkgname) pkgconfig + for_ mods (copyModule workingDir (C.srcDir installDir)) + for_ tcms (copyTemplateModule workingDir (C.srcDir installDir)) + putStrLn "Copying Ordinary" + moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Ordinary" <.> "hs" + moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Template" <.> "hs" + moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "TH" <.> "hs" + moduleFileCopy workingDir (C.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 @@ -206,7 +244,6 @@ 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" @@ -217,32 +254,28 @@ >>= flip when (copyFileWithMD5Check (wdir tlhfile) (ddir tlhfile)) doesFileExist (wdir tlcppfile) >>= flip when (copyFileWithMD5Check (wdir tlcppfile) (ddir tlcppfile)) - for_ cihs $ \header-> do + 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 + let (fnamebody, fnameext) = splitExtension fname + (mdir, mfile) = moduleDirFile fnamebody origfpath = wdir fname - (mfile',_mext') = splitExtension mfile + (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 @@ -254,8 +287,8 @@ moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs" moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot" when (hasProxy . cihClass . cmCIH $ m) $ - moduleFileCopy wdir ddir $ modbase <> ".Proxy.hs" - + moduleFileCopy wdir ddir $ + modbase <> ".Proxy.hs" copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO () copyTemplateModule wdir ddir m = do diff --git a/src/FFICXX/Generate/Code/Cabal.hs b/src/FFICXX/Generate/Code/Cabal.hs --- a/src/FFICXX/Generate/Code/Cabal.hs +++ b/src/FFICXX/Generate/Code/Cabal.hs @@ -1,46 +1,49 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} module FFICXX.Generate.Code.Cabal where -import Data.Aeson.Encode.Pretty (encodePretty) +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 Data.List (intercalate, nub) +import Data.Text (Text) +import qualified Data.Text as T (intercalate, pack, replicate, unlines) 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 qualified Data.Text.Lazy as TL (toStrict) +import Data.Text.Template (substitute) +import FFICXX.Generate.Type.Cabal + ( AddCInc (..), + AddCSrc (..), + BuildType (..), + Cabal (..), + CabalName (..), + GeneratedCabalInfo (..), + ) +import FFICXX.Generate.Type.Class (hasProxy) import FFICXX.Generate.Type.Module --- import FFICXX.Generate.Type.PackageInterface -import FFICXX.Generate.Util - + ( ClassImportHeader (..), + ClassModule (..), + PackageConfig (..), + TemplateClassImportHeader, + TemplateClassModule (..), + TopLevelImportHeader (..), + ) +import FFICXX.Generate.Util (contextT) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import System.FilePath ((<.>), ()) 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 = +genCsrcFiles :: + (TopLevelImportHeader, [ClassModule]) -> + [AddCInc] -> + [AddCSrc] -> + [String] +genCsrcFiles (tih, cmods) acincs acsrcs = let selfheaders' = do x <- cmods let y = cmCIH x @@ -53,66 +56,71 @@ 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 + 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 = +genIncludeFiles :: + -- | package name + String -> + ([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 + in (pkgname <> "Type.h") : includeFileStrs -- for library -genCppFiles :: (TopLevelImportHeader,[ClassModule]) - -> [AddCSrc] - -> [String] -genCppFiles (tih,cmods) acsrcs = +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 + 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 +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, summarymod <> ".Ordinary", summarymod <> ".Template", summarymod <> ".TH"] + <> cmodstrs + <> rawType + <> ffi + <> interface + <> cast + <> implementation + <> proxy + <> template + <> th -- | generate other modules in cabal file genOtherModules :: [ClassModule] -> [String] @@ -120,19 +128,19 @@ -- | generate additional package dependencies. genPkgDeps :: [CabalName] -> [String] -genPkgDeps cs = [ "base > 4 && < 5" - , "fficxx >= 0.5" - , "fficxx-runtime >= 0.5" - , "template-haskell" - ] - ++ map unCabalName cs - - +genPkgDeps cs = + [ "base > 4 && < 5", + "fficxx >= 0.7", + "fficxx-runtime >= 0.7", + "template-haskell" + ] + ++ map unCabalName cs -- | cabalTemplate :: Text cabalTemplate = - "Name: $pkgname\n\ + "Cabal-version: 3.0\n\ + \Name: $pkgname\n\ \Version: $version\n\ \Synopsis: $synopsis\n\ \Description: $description\n\ @@ -142,9 +150,8 @@ \Author: $author\n\ \Maintainer: $maintainer\n\ \Category: $category\n\ - \Tested-with: GHC >= 7.6\n\ + \Tested-with: GHC == 9.0.2 || == 9.2.4 || == 9.4.2 \n\ \$buildtype\n\ - \cabal-version: >= 2\n\ \Extra-source-files:\n\ \$extraFiles\n\ \$csrcFiles\n\ @@ -168,19 +175,20 @@ \ pkgconfig-depends: $pkgconfigDepends\n\ \ Install-includes:\n\ \$includeFiles\n\ - \ C-sources:\n\ + \ Cxx-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 = +genCabalInfo :: + Cabal -> + String -> + PackageConfig -> + -- | extra libs + [String] -> + -- | cxx options + [String] -> + GeneratedCabalInfo +genCabalInfo cabal summarymodule pkgconfig extralibs cxxopts = let tih = pcfg_topLevelImportHeader pkgconfig classmodules = pcfg_classModules pkgconfig cih = pcfg_classImportHeaders pkgconfig @@ -189,95 +197,100 @@ 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 - } - + 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 = map T.pack cxxopts, + 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) - ] - + 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 +buildCabalFile :: + Cabal -> + String -> + PackageConfig -> + -- | Extra libs + [String] -> + -- | cxx options + [String] -> + -- | Cabal file path + FilePath -> + IO () +buildCabalFile cabal summarymodule pkgconfig extralibs cxxopts cabalfile = do + let cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs cxxopts 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 +buildJSONFile :: + Cabal -> + String -> + PackageConfig -> + -- | Extra libs + [String] -> + -- | cxx options + [String] -> + -- | JSON file path + FilePath -> + IO () +buildJSONFile cabal summarymodule pkgconfig extralibs cxxopts jsonfile = do + let cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs cxxopts BL.writeFile jsonfile (encodePretty cinfo) diff --git a/src/FFICXX/Generate/Code/Cpp.hs b/src/FFICXX/Generate/Code/Cpp.hs --- a/src/FFICXX/Generate/Code/Cpp.hs +++ b/src/FFICXX/Generate/Code/Cpp.hs @@ -1,67 +1,68 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# 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 Data.Char (toUpper) +import Data.Functor.Identity (Identity) +import Data.List (intercalate, intersperse) 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 ) + ( CFunSig (..), + accessorCFunSig, + argToCallCExp, + argsToCTypVar, + argsToCTypVarNoSelf, + c2Cxx, + cxx2C, + genericFuncArgs, + genericFuncRet, + returnCType, + tmplAccessorToTFun, + tmplAllArgsToCTypVar, + tmplAppTypeFromForm, + tmplArgToCTypVar, + tmplArgToCallCExp, + tmplMemFuncArgToCTypVar, + tmplMemFuncReturnCType, + tmplReturnCType, + ) +import FFICXX.Generate.Name + ( aliasedFuncName, + cppFuncName, + ffiClassName, + ffiTmplFuncName, + hsTemplateMemberFunctionName, + ) +import FFICXX.Generate.Type.Class + ( Accessor (Getter, Setter), + Arg (..), + CPPTypes (..), + CTypes (..), + Class (..), + Form (FormNested, FormSimple), + Function (..), + IsConst (Const, NoConst), + Selfness (NoSelf, Self), + TLOrdinary (..), + TLTemplate (..), + TemplateAppInfo (..), + TemplateClass (..), + TemplateFunction (..), + TemplateMemberFunction (..), + Types (..), + Variable (..), + argsFromOpExp, + isDeleteFunc, + isNewFunc, + isStaticFunc, + isVirtualFunc, + opSymbol, + virtualFuncs, + ) +import FFICXX.Generate.Type.Module (ClassImportHeader (..)) +import FFICXX.Generate.Util (firstUpper, toUppers) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) -- -- @@ -76,73 +77,71 @@ 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)) - ] + [ 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" - + classname_t = classname <> "_t" + classname_p = classname <> "_p" genCppHeaderMacroType :: Class -> [R.CStatement Identity] genCppHeaderMacroType c = - [ R.Comment "Opaque type definition for $classname" ] + [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 + 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 + 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 + 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 - + 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) + 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 - + 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) = +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)] + 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)] + 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)] + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] ---- ---- Definition @@ -152,78 +151,81 @@ genCppDefMacroVirtual :: Class -> R.CMacro Identity genCppDefMacroVirtual aclass = - let funcDefStr = intercalate "\n" - . map (R.renderCStmt . funcToDef aclass) - . virtualFuncs - . class_funcs - $ 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 ] + 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 + 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 ] + 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) + 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 + 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 + 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 - ] + 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.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) = +genCppDefInstVirtual (p, c) = let macroname = map toUpper (ffiClassName p) <> "_DEF_VIRT" - in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] + 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)] + 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)] + in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)] ----------------- @@ -237,198 +239,236 @@ -- TOP LEVEL FUNCTIONS -- ------------------------- -topLevelDecl :: TopLevel -> R.CFunDecl Identity +topLevelDecl :: TLOrdinary -> R.CFunDecl Identity topLevelDecl TopLevelFunction {..} = R.CFunDecl ret func args where - ret = returnCType toplevelfunc_ret + 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 + ret = returnCType toplevelvar_ret func = R.sname ("TopLevel_" <> maybe toplevelvar_name id toplevelvar_alias) -genTopLevelCppDefinition :: TopLevel -> R.CStatement Identity +genTopLevelCppDefinition :: TLOrdinary -> 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 + 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 + in R.CDefinition Nothing decl body genTmplFunCpp :: - IsCPrimitive - -> TemplateClass - -> TemplateFunction - -> R.CMacro Identity + 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 ))) + 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))) +genTLTmplFunCpp :: + IsCPrimitive -> + TLTemplate -> + R.CMacro Identity +genTLTmplFunCpp b t@TopLevelTemplateFunction {..} = + R.Define + (R.sname macroname) + (map R.sname ("callmod" : topleveltfunc_params)) + [ R.CExtern [R.CDeclaration decl], + topLevelTemplateFunToDef b t, + autoinst + ] + where + nsuffix = intersperse (R.NamePart "_") $ map R.NamePart topleveltfunc_params + suffix = case b of CPrim -> "_s"; NonCPrim -> "" + macroname = firstUpper topleveltfunc_name <> "_instance" <> suffix + decl = topLevelTemplateFunToDecl b t + autoinst = + R.CInit + ( R.CVarDecl + R.CTAuto + (R.CName (R.NamePart "a_" : R.NamePart "callmod" : R.NamePart ("_TL_" <> topleveltfunc_name <> "_") : nsuffix)) + ) + (R.CVar (R.CName (R.NamePart ("TL_" <> topleveltfunc_name <> "_") : nsuffix))) + genTmplVarCpp :: - IsCPrimitive - -> TemplateClass - -> Variable - -> [ R.CMacro Identity ] -genTmplVarCpp b t@TmplCls {..} var@(Variable (Arg {..})) = - [ gen var Getter, gen var Setter ] + 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 -> "" } + 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 ))) - ] + 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 + IsCPrimitive -> + TemplateClass -> + -- | (member functions, member accessors) + ([TemplateFunction], [Variable]) -> + 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] + IsCPrimitive -> + Types -> + R.CExp Identity -> + [R.CStatement Identity] returnCpp b ret caller = case ret of Void -> - [ R.CExpSA caller ] + [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 ] + [ 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 ] + [R.CReturn $ R.CAddr caller] CT _ _ -> - [R.CReturn caller ] + [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 ] + [ 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' + 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 ] + [ 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' + 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.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 ] - ] + [R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str)] + [R.CNew (R.sname str) [caller]] ] - where str = ffiClassName c' + 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.CNew (R.sname cpptype) [caller]), + R.CReturn $ R.CTApp (R.sname "static_cast") - [ R.CTStar R.CTVoid ] - [ R.CVar (R.sname "r") ] + [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.CNew (R.sname cpptype) [caller]), + R.CReturn $ R.CTApp (R.sname "static_cast") - [ R.CTStar R.CTVoid ] - [ R.CVar (R.sname "r") ] + [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.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") ] + [ R.CTApp + (R.sname "static_cast") + [R.CTStar R.CTVoid] + [R.CVar (R.sname "r")] ] ] TemplateType _ -> @@ -436,22 +476,22 @@ TemplateParam typ -> [ R.CReturn $ case b of - CPrim -> caller + 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 ] + [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 + 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 ] + [R.CTSimple (R.CName [R.NamePart typ, R.NamePart "_t"]), R.CTSimple (R.sname typ)] + [caller] ] -- Function Declaration and Definition @@ -459,98 +499,112 @@ funcToDecl :: Class -> Function -> R.CFunDecl Identity funcToDecl c func | isNewFunc func || isStaticFunc func = - let ret = returnCType (genericFuncRet 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 + args = argsToCTypVarNoSelf (genericFuncArgs func) + in R.CFunDecl ret fname args | otherwise = - let ret = returnCType (genericFuncRet func) + 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 + 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 + 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 + 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 + 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.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 + in R.CDefinition Nothing (funcToDecl c func) body -- template function declaration and definition - tmplFunToDecl :: - IsCPrimitive - -> TemplateClass - -> TemplateFunction - -> R.CFunDecl Identity + 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 + 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 --- | +-- | top-level (bare) template function declaration +topLevelTemplateFunToDecl :: + IsCPrimitive -> + TLTemplate -> + R.CFunDecl Identity +topLevelTemplateFunToDecl b (TopLevelTemplateFunction {..}) = + let nsuffix = intersperse (R.NamePart "_") $ map R.NamePart topleveltfunc_params + ret = tmplReturnCType b topleveltfunc_ret + func = R.CName (R.NamePart ("TL_" <> topleveltfunc_name <> "_") : nsuffix) + args = map (tmplArgToCTypVar b) topleveltfunc_args + in R.CFunDecl ret func args + +-- | function definition in a template class tmplFunToDef :: - IsCPrimitive - -> TemplateClass - -> TemplateFunction - -> R.CStatement Identity + IsCPrimitive -> + TemplateClass -> + TemplateFunction -> + R.CStatement Identity tmplFunToDef b t@TmplCls {..} f = - R.CDefinition (Just R.Inline) (tmplFunToDecl b t f) body + R.CDefinition (Just R.Inline) (tmplFunToDecl b t f) body where typparams = map (R.CTSimple . R.sname) tclass_params body = @@ -569,72 +623,90 @@ (R.sname inner) typparams (map (tmplArgToCallCExp b) tfun_new_args) - in [ R.CReturn $ R.CTApp (R.sname "static_cast") [R.CTStar R.CTVoid] [caller] ] + 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") ] + [R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams] + [R.CVar (R.sname "p")] ] - TFun {..} -> + 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.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) + ( R.CApp + (R.CVar (R.sname tfun_oname)) + (map (tmplArgToCallCExp b) tfun_args) ) - TFunOp {..} -> + 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.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)) + ( R.CApp + (R.CVar (R.sname ("operator" <> opSymbol tfun_opexp))) + (map (tmplArgToCallCExp b) (argsFromOpExp tfun_opexp)) ) +-- | function definition in a template class +topLevelTemplateFunToDef :: + IsCPrimitive -> + TLTemplate -> + R.CStatement Identity +topLevelTemplateFunToDef b t@TopLevelTemplateFunction {..} = + R.CDefinition (Just R.Inline) (topLevelTemplateFunToDecl b t) body + where + typparams = map (R.CTSimple . R.sname) topleveltfunc_params + body = + returnCpp b (topleveltfunc_ret) $ + R.CTApp + (R.sname topleveltfunc_oname) + typparams + (map (tmplArgToCallCExp b) topleveltfunc_args) +-- | tmplVarToDef :: - IsCPrimitive - -> TemplateClass - -> Variable - -> Accessor - -> R.CStatement Identity + 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 + 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"))) - ] + 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 @@ -644,39 +716,41 @@ 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" - ) - ] + 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 + in R.CFunDecl ret fname args accessorsToDecls :: [Variable] -> [R.CFunDecl Identity] accessorsToDecls vs = - concatMap (\v -> [accessorToDecl v Getter,accessorToDecl v Setter]) 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.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 ] - + 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 @@ -687,25 +761,26 @@ 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 + 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 + 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)) - ) + 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 --- a/src/FFICXX/Generate/Code/HsCast.hs +++ b/src/FFICXX/Generate/Code/HsCast.hs @@ -1,37 +1,47 @@ 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) +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, + tyPtr, + tyapp, + tycon, + unqual, + ) +import Language.Haskell.Exts.Build (app) +import Language.Haskell.Exts.Syntax (Decl (..), InstDecl (..)) + ----- 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) + [ 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 = + | (not . isAbstractClass) c = let iname = typeclassName c - (_,rname) = hsClassName 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) + 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) + | (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 --- a/src/FFICXX/Generate/Code/HsFFI.hs +++ b/src/FFICXX/Generate/Code/HsFFI.hs @@ -3,48 +3,47 @@ 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 Data.Maybe (fromMaybe, mapMaybe) 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 ) - + ( CFunSig (..), + accessorCFunSig, + genericFuncArgs, + genericFuncRet, + hsFFIFuncTyp, + ) +import FFICXX.Generate.Dependency + ( class_allparents, + ) +import FFICXX.Generate.Name + ( aliasedFuncName, + ffiClassName, + hscAccessorName, + hscFuncName, + subModuleName, + ) +import FFICXX.Generate.Type.Class + ( Accessor (Getter, Setter), + Arg (..), + Class (..), + Function (..), + Selfness (NoSelf, Self), + TLOrdinary (..), + 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) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import Language.Haskell.Exts.Syntax (Decl (..), ImportDecl (..)) +import System.FilePath ((<.>)) genHsFFI :: ClassImportHeader -> [Decl ()] genHsFFI header = @@ -56,56 +55,54 @@ -- 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 + 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 + 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 :: 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 - + 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") - +genImportInFFI = fmap (mkImport . subModuleName) . cmImportedSubmodulesForFFI ---------------------------- -- for top level function -- ---------------------------- -genTopLevelFFI :: TopLevelImportHeader -> TopLevel -> Decl () +genTopLevelFFI :: TopLevelImportHeader -> TLOrdinary -> 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) + 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 --- a/src/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/src/FFICXX/Generate/Code/HsFrontEnd.hs @@ -1,94 +1,168 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# 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 Control.Monad.Reader (Reader) +import Data.Either (lefts, rights) +import qualified Data.List as L +import FFICXX.Generate.Code.Primitive + ( CFunSig (..), + HsFunSig (..), + accessorSignature, + classConstraints, + convertCpp2HS, + extractArgRetTypes, + functionSignature, + hsFuncXformer, + ) +import FFICXX.Generate.Dependency + ( argumentDependency, + extractClassDepForTLOrdinary, + extractClassDepForTLTemplate, + returnDependency, + ) +import FFICXX.Generate.Dependency.Graph + ( getCyclicDepSubmodules, + locateInDepCycles, + ) +import FFICXX.Generate.Name + ( accessorName, + aliasedFuncName, + getClassModuleBase, + getTClassModuleBase, + hsClassName, + hsFrontNameForTopLevel, + hsFuncName, + hscAccessorName, + hscFuncName, + subModuleName, + typeclassName, + ) +import FFICXX.Generate.Type.Annotate (AnnotateMap) import FFICXX.Generate.Type.Class -import FFICXX.Generate.Type.Annotate + ( Accessor (..), + Class (..), + TLOrdinary (..), + TLTemplate, + TopLevel (TLOrdinary), + Types (..), + constructorFuncs, + isAbstractClass, + isNewFunc, + isVirtualFunc, + nonVirtualNotNewFuncs, + staticFuncs, + virtualFuncs, + ) import FFICXX.Generate.Type.Module -import FFICXX.Generate.Util + ( ClassModule (..), + DepCycles, + TemplateClassModule (..), + ) +import FFICXX.Generate.Util (toLowers) import FFICXX.Generate.Util.HaskellSrcExts - + ( classA, + clsDecl, + con, + conDecl, + cxEmpty, + cxTuple, + eabs, + ethingall, + evar, + ihcon, + insDecl, + insType, + irule, + mkBind1, + mkClass, + mkData, + mkDeriving, + mkFun, + mkFunSig, + mkImport, + mkImportSrc, + mkInstance, + mkNewtype, + mkPVar, + mkPVarSig, + mkTBind, + mkTVar, + mkVar, + nonamespace, + pbind, + qualConDecl, + tyForall, + tyPtr, + tyapp, + tycon, + tyfun, + unkindedVar, + unqual, + ) +import Language.Haskell.Exts.Build (app, letE, name, pApp) +import Language.Haskell.Exts.Syntax + ( Context (CxTuple), + Decl (..), + ExportSpec (..), + ImportDecl (..), + ) +import System.FilePath ((<.>)) -genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ()) -genHsFrontDecl c = do +genHsFrontDecl :: Bool -> Class -> Reader AnnotateMap (Decl ()) +genHsFrontDecl isHsBoot 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 + -- for hs-boot, we only have instance head. + cdecl' = mkClass (CxTuple () []) (typeclassName c) [mkTBind "a"] [] sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f) body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c - return cdecl + if isHsBoot + then return cdecl' + else return cdecl ------------------- genHsFrontInst :: Class -> Class -> [Decl ()] genHsFrontInst parent child - | (not.isAbstractClass) 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)) + where + rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f)) body = map (insDecl . defn) . virtualFuncs . class_funcs $ parent - in [idecl] + in [idecl] | otherwise = [] - - - --------------------- -genHsFrontInstNew :: Class -- ^ only concrete class - -> Reader AnnotateMap [Decl ()] +genHsFrontInstNew :: + -- | only concrete class + 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. + 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 + 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) + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing + where + nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) ----- @@ -96,7 +170,7 @@ 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 + in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing ----- @@ -104,106 +178,113 @@ 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 - - - + 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) + [ 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")) - + 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") - +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") - +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 :: TLOrdinary -> [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 + let fname = hsFrontNameForTopLevel (TLOrdinary 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 - + let fname = hsFrontNameForTopLevel (TLOrdinary 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 -- @@ -211,31 +292,39 @@ 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)) ] + 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) + 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) - + where + fs = class_funcs c + fns = map (aliasedFuncName c) (staticFuncs fs) ------------ -- Import -- @@ -244,79 +333,72 @@ genExtraImport :: ClassModule -> [ImportDecl ()] genExtraImport cm = map mkImport (cmExtraImport cm) - genImportInModule :: Class -> [ImportDecl ()] -genImportInModule x = map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"] +genImportInModule x = map (\y -> mkImport (getClassModuleBase x <.> y)) ["RawType", "Interface", "Implementation"] +mkImportWithDepCycles :: DepCycles -> String -> String -> ImportDecl () +mkImportWithDepCycles depCycles self imported = + let mloc = locateInDepCycles (self, imported) depCycles + in case mloc of + Just (idxSelf, idxImported) + | idxImported > idxSelf -> + mkImportSrc imported + _ -> mkImport imported -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") - ) +genImportInInterface :: Bool -> DepCycles -> ClassModule -> [ImportDecl ()] +genImportInInterface isHsBoot depCycles m = + let modSelf = cmModule m <.> "Interface" + imported = cmImportedSubmodulesForInterface m + (rdepsU, rdepsD) = getCyclicDepSubmodules modSelf depCycles + in if isHsBoot + then -- for hs-boot file, we ignore all module imports in the cycle. + -- TODO: This is likely to be broken in more general cases. + -- Keep improving this as hs-boot allows. + let imported' = fmap subModuleName imported L.\\ (rdepsU <> rdepsD) + in fmap mkImport imported' + else fmap (mkImportWithDepCycles depCycles modSelf . subModuleName) imported + -- | genImportInCast :: ClassModule -> [ImportDecl ()] -genImportInCast m = [ mkImport (cmModule m <.> "RawType") - , mkImport (cmModule m <.> "Interface") ] +genImportInCast m = + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForCast m --- | 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 + fmap (mkImport . subModuleName) $ cmImportedSubmodulesForImplementation m +-- | generate import list for a given top-level ordinary function +-- currently this may generate duplicate import list. +-- TODO: eliminate duplicated imports. +-- TODO2: should be refactored out. +genImportForTLOrdinary :: TLOrdinary -> [ImportDecl ()] +genImportForTLOrdinary f = + let dep4func = extractClassDepForTLOrdinary f + ecs = returnDependency dep4func ++ argumentDependency dep4func + cmods = L.nub $ map getClassModuleBase $ rights ecs + tmods = L.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 a given top-level function +-- | generate import list for a given top-level template function -- currently this may generate duplicate import list. -- TODO: eliminate duplicated imports. -genImportForTopLevel :: TopLevel -> [ImportDecl ()] -genImportForTopLevel f = - let dep4func = extractClassDepForTopLevel f +-- TODO2: should be refactored out. +genImportForTLTemplate :: TLTemplate -> [ImportDecl ()] +genImportForTLTemplate f = + let dep4func = extractClassDepForTLTemplate 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 + cmods = L.nub $ map getClassModuleBase $ rights ecs + tmods = L.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 - + String -> + ([ClassModule], [TemplateClassModule]) -> + [ImportDecl ()] +genImportInTopLevel modname (mods, _tmods) = + map (mkImport . cmModule) mods + ++ map mkImport [modname <.> "Template", modname <.> "TH", modname <.> "Ordinary"] diff --git a/src/FFICXX/Generate/Code/HsProxy.hs b/src/FFICXX/Generate/Code/HsProxy.hs --- a/src/FFICXX/Generate/Code/HsProxy.hs +++ b/src/FFICXX/Generate/Code/HsProxy.hs @@ -2,36 +2,46 @@ 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 Data.List as L (foldr1) -- -import qualified FFICXX.Runtime.CodeGen.Cxx as R -import FFICXX.Generate.Util.HaskellSrcExts - ( con, inapp, mkFun, mkVar - , op, qualifier - , tyapp, tycon, tylist - ) +import FFICXX.Generate.Util.HaskellSrcExts + ( con, + inapp, + mkFun, + mkVar, + op, + qualifier, + tyapp, + tycon, + tylist, + ) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import Language.Haskell.Exts.Build (app, doE, listE, qualStmt, strE) +import Language.Haskell.Exts.Syntax (Decl (..)) 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 [] + 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 --- a/src/FFICXX/Generate/Code/HsTemplate.hs +++ b/src/FFICXX/Generate/Code/HsTemplate.hs @@ -1,72 +1,112 @@ -{-# LANGUAGE LambdaCase #-} +{-# 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 qualified Data.List as L (foldr1) +import FFICXX.Generate.Code.Cpp + ( genTLTmplFunCpp, + genTmplClassCpp, + genTmplFunCpp, + genTmplVarCpp, + ) +import FFICXX.Generate.Code.HsCast (castBody) +import FFICXX.Generate.Code.Primitive + ( convertCpp2HS, + convertCpp2HS4Tmpl, + functionSignatureT, + functionSignatureTMF, + functionSignatureTT, + tmplAccessorToTFun, + ) +import FFICXX.Generate.Dependency (calculateDependency) +import FFICXX.Generate.Name + ( ffiTmplFuncName, + hsTemplateClassName, + hsTemplateMemberFunctionName, + hsTemplateMemberFunctionNameTH, + hsTmplFuncName, + hsTmplFuncNameTH, + subModuleName, + tmplAccessorName, + typeclassNameT, + ) +import FFICXX.Generate.Type.Class + ( Accessor (Getter, Setter), + Arg (..), + Class (..), + TLTemplate (..), + TemplateClass (..), + TemplateFunction (..), + TemplateMemberFunction (..), + Types (Void), + Variable (..), + ) +import FFICXX.Generate.Type.Module + ( ClassImportHeader (..), + TemplateClassImportHeader (..), + TemplateClassSubmoduleType (..), + TopLevelImportHeader (..), + ) +import FFICXX.Generate.Util (firstUpper) 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 - ) - + ( bracketExp, + clsDecl, + con, + conDecl, + cxEmpty, + generator, + inapp, + insDecl, + insType, + match, + mkBind1, + mkClass, + mkData, + mkFun, + mkFunSig, + mkImport, + mkInstance, + mkNewtype, + mkPVar, + mkTBind, + mkTVar, + mkVar, + op, + parenSplice, + pbind_, + qualConDecl, + qualifier, + tyPtr, + tySplice, + tyapp, + tycon, + tyfun, + tylist, + typeBracket, + ) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import Language.Haskell.Exts.Build + ( app, + binds, + caseE, + doE, + lamE, + letE, + letStmt, + listE, + name, + pApp, + pTuple, + paren, + qualStmt, + strE, + tuple, + wildcard, + ) +import Language.Haskell.Exts.Syntax (Boxed (Boxed), Decl (..), ImportDecl (..), Type (TyTuple)) ------------------------------ -- Template member function -- @@ -75,7 +115,7 @@ genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()] genTemplateMemberFunctions cih = let c = cihClass cih - in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c) + in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c) -- TODO: combine this with genTmplInstance genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()] @@ -84,90 +124,104 @@ nh = hsTemplateMemberFunctionNameTH c f v = mkVar p = mkPVar - itps = zip ([1..]::[Int]) (tmf_params f) - tvars = map (\(i,_) -> "typ" ++ show i) itps + 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") ] + 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"]) + 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 - ] + 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 + 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")) + 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" ) ] + 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"])) ] + 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" - ] - ) - ) + (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 + 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"]) + [ 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"]) + [ 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") @@ -178,111 +232,98 @@ 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") - ) + fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTemplate, t0) -- | 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 + [ 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) - ] + 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"] - ) + fmap (mkImport . subModuleName) $ calculateDependency $ Left (TCSTTH, t0) -- | genTmplImplementation :: TemplateClass -> [Decl ()] genTmplImplementation t = - concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars 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 + 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") ] + 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 + 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] + ( 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 ()] + TemplateClassImportHeader -> + [Decl ()] genTmplInstance tcih = - mkFun - fname - sig - (p "isCprim" : zipWith (\x y -> pTuple [p x,p y]) qtvars pvars) - rhs - Nothing + 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 @@ -291,150 +332,376 @@ 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 + 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) + 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 + 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] - ) + 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) + 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" + (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) - ) - ) - ] - + 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 "") + (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" ] - , 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) - ] + 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 + 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")) + [ 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"]) + [ 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") + ] - 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") - ] +--------------- +-- top-level -- +--------------- + +-- | +genTLTemplateInterface :: TLTemplate -> [Decl ()] +genTLTemplateInterface t = + [ mkClass cxEmpty (firstUpper (topleveltfunc_name t)) (map mkTBind tps) methods + ] + where + tps = topleveltfunc_params t + ctyp = convertCpp2HS Nothing (topleveltfunc_ret t) + lst = map (convertCpp2HS Nothing . arg_type) (topleveltfunc_args t) + sigdecl = mkFunSig (topleveltfunc_name t) $ foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + methods = [clsDecl sigdecl] + +-- | +genTLTemplateImplementation :: TLTemplate -> [Decl ()] +genTLTemplateImplementation t = + mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts) + where + v = mkVar + p = mkPVar + itps = zip ([1 ..] :: [Int]) (topleveltfunc_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 = "TL" + nh = "t_" <> topleveltfunc_name t + nc = topleveltfunc_name t + 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' = + let e = error "genTLTemplateImplementation" + spls = map (tySplice . parenSplice . mkVar) $ topleveltfunc_params t + ctyp = convertCpp2HS4Tmpl e Nothing spls (topleveltfunc_ret t) + lst = map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (topleveltfunc_args t) + in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp]) + tassgns = map (\(i, tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps + bstmts = + binds + [ mkBind1 + "tyf" + [wildcard] + ( letE + tassgns + (bracketExp (typeBracket sig')) + ) + Nothing + ] + +genTLTemplateInstance :: + TopLevelImportHeader -> + TLTemplate -> + [Decl ()] +genTLTemplateInstance tih t = + mkFun + fname + sig + (p "isCprim" : zipWith (\x y -> pTuple [p x, p y]) qtvars pvars) + rhs + Nothing + where + p = mkPVar + v = mkVar + tcname = firstUpper (topleveltfunc_name t) + fname = "gen" <> tcname <> "InstanceFor" + itps = zip ([1 ..] :: [Int]) (topleveltfunc_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")] + -- 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) + <> [genstmt "f" (1 :: Int)] + <> [ 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) + genstmt prefix n = + generator + (p (prefix <> show n)) + ( v "mkFunc" `app` strE (topleveltfunc_name t) + `app` v ("t_" <> topleveltfunc_name t) + `app` typs_v + `app` v "suffix" + ) + lststmt = [pbind_ (p "lst") (listE [v "f1"])] + -- 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 (tcname <> "_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 + includeStatic = + strE $ + concatMap + (<> "\n") + ( [R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h"))] + ++ map + R.renderCMacro + ( map R.Include (tihExtraHeadersInCPP tih) + ++ [genTLTmplFunCpp CPrim t, genTLTmplFunCpp NonCPrim t] + ) + ) + {- + 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` (v "con" `app` strE tcname) + `app` foldl1 + (\f x -> con "AppT" `app` f `app` x) + (v "con" `app` strE tcname : map v tvars) + `app` (v "lst") + ] diff --git a/src/FFICXX/Generate/Code/Primitive.hs b/src/FFICXX/Generate/Code/Primitive.hs --- a/src/FFICXX/Generate/Code/Primitive.hs +++ b/src/FFICXX/Generate/Code/Primitive.hs @@ -1,1003 +1,1067 @@ -{-# 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 +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} + +module FFICXX.Generate.Code.Primitive where + +import Control.Monad.Trans.State (get, put, runState) +import Data.Functor.Identity (Identity) +import FFICXX.Generate.Name + ( ffiClassName, + hsClassName, + hsClassNameForTArg, + hsTemplateClassName, + tmplAccessorName, + typeclassName, + typeclassNameFromStr, + ) +import FFICXX.Generate.Type.Class + ( Accessor (Getter, Setter), + Arg (..), + CPPTypes (..), + CTypes (..), + Class (..), + 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, + tyPtr, + tySplice, + tyapp, + tycon, + tyfun, + unit_tycon, + unqual, + ) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import FFICXX.Runtime.TH (IsCPrimitive (CPrim, NonCPrim)) +import Language.Haskell.Exts.Syntax (Asst (..), Context, Type (..)) + +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 -> + 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) 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 :: + -- | self + Type () -> + Maybe Class -> + -- | type paramemter splice + [Type ()] -> + 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 :: + -- | class (Nothing for top-level function) + Maybe Class -> + -- | is virtual function? + Bool -> + -- | C type signature information for a given function -- (Args,Types) -- ^ (argument types, return type) of a given function + CFunSig -> + -- | Haskell type signature information for the function -- ([Type ()],[Asst ()]) -- ^ (types, class constraints) + HsFunSig +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_ diff --git a/src/FFICXX/Generate/Config.hs b/src/FFICXX/Generate/Config.hs --- a/src/FFICXX/Generate/Config.hs +++ b/src/FFICXX/Generate/Config.hs @@ -1,26 +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 ) - +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 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] +data SimpleBuilderConfig = SimpleBuilderConfig + { sbcTopModule :: String, + sbcModUnitMap :: ModuleUnitMap, + sbcCabal :: Cabal, + sbcClasses :: [Class], + sbcTopLevels :: [TopLevel], + sbcTemplates :: [TemplateClassImportHeader], + sbcExtraLibs :: [String], + sbcCxxOpts :: [String], + sbcExtraDeps :: [(String, [String])], + sbcStaticFiles :: [String] } diff --git a/src/FFICXX/Generate/ContentMaker.hs b/src/FFICXX/Generate/ContentMaker.hs --- a/src/FFICXX/Generate/ContentMaker.hs +++ b/src/FFICXX/Generate/ContentMaker.hs @@ -3,529 +3,747 @@ 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) +import Control.Lens (at, (&), (.~)) +import Control.Monad.Trans.Reader (runReader) +import Data.Either (rights) +import Data.Functor.Identity (Identity) +import Data.List (intercalate, nub) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import FFICXX.Generate.Code.Cpp + ( genAllCppHeaderInclude, + genCppDefInstAccessor, + genCppDefInstNonVirtual, + genCppDefInstVirtual, + genCppDefMacroAccessor, + genCppDefMacroNonVirtual, + genCppDefMacroTemplateMemberFunction, + genCppDefMacroVirtual, + genCppHeaderInstAccessor, + genCppHeaderInstNonVirtual, + genCppHeaderInstVirtual, + genCppHeaderMacroAccessor, + genCppHeaderMacroNonVirtual, + genCppHeaderMacroType, + genCppHeaderMacroVirtual, + 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, + genImportForTLOrdinary, + genImportForTLTemplate, + genImportInCast, + genImportInImplementation, + genImportInInterface, + genImportInModule, + genImportInTopLevel, + genTopLevelDef, + hsClassRawType, + ) +import FFICXX.Generate.Code.HsProxy (genProxyInstance) +import FFICXX.Generate.Code.HsTemplate + ( genImportInTH, + genImportInTemplate, + genTLTemplateImplementation, + genTLTemplateInstance, + genTLTemplateInterface, + genTemplateMemberFunctions, + genTmplImplementation, + genTmplInstance, + genTmplInterface, + ) +import FFICXX.Generate.Dependency + ( class_allparents, + mkDaughterMap, + mkDaughterSelfMap, + ) +import FFICXX.Generate.Name + ( ffiClassName, + hsClassName, + hsFrontNameForTopLevel, + ) +import FFICXX.Generate.Type.Annotate (AnnotateMap) +import FFICXX.Generate.Type.Class + ( Class (..), + ClassGlobal (..), + DaughterMap, + ProtectedMethod (..), + TopLevel (TLOrdinary, TLTemplate), + filterTLOrdinary, + filterTLTemplate, + isAbstractClass, + ) +import FFICXX.Generate.Type.Module + ( ClassImportHeader (..), + ClassModule (..), + DepCycles, + TemplateClassImportHeader (..), + TemplateClassModule (..), + TopLevelImportHeader (..), + ) +import FFICXX.Generate.Type.PackageInterface + ( ClassName (..), + PackageInterface, + PackageName (..), + ) +import FFICXX.Generate.Util (firstUpper) +import FFICXX.Generate.Util.HaskellSrcExts + ( emodule, + evar, + lang, + mkImport, + mkModule, + mkModuleE, + unqual, + ) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import qualified FFICXX.Runtime.CodeGen.Cxx as R +import Language.Haskell.Exts.Syntax + ( Decl (..), + EWildcard (EWildcard), + ExportSpec (EThingWith), + Module (..), + ) +import System.FilePath ((<.>), ()) + +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 :: + -- | C prefix + String -> + 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 :: + -- | C prefix + String -> + 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) $ filterTLOrdinary (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) $ + filterTLOrdinary (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", "InterruptibleFFI"]] + 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 -> + DepCycles -> + ClassModule -> + Module () +buildInterfaceHs amap depCycles 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 False depCycles m + <> genExtraImport m + ifaceBody = + runReader (mapM (genHsFrontDecl False) classes) amap + <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes + <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes + +-- | +buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module () +buildInterfaceHsBoot depCycles m = + mkModule + (cmModule m <.> "Interface") + [ lang + [ "EmptyDataDecls", + "ExistentialQuantification", + "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "MultiParamTypeClasses", + "ScopedTypeVariables", + "TypeFamilies", + "TypeSynonymInstances" + ] + ] + hsbootImports + hsbootBody + where + c = cihClass (cmCIH m) + hsbootImports = + [ mkImport "Data.Word", + mkImport "Data.Int", + mkImport "Foreign.C", + mkImport "Foreign.Ptr", + mkImport "FFICXX.Runtime.Cast" + ] + <> genImportInInterface True depCycles m + <> genExtraImport m + hsbootBody = + runReader (mapM (genHsFrontDecl True) [c]) M.empty + +-- | +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) + +-- | +buildModuleHs :: ClassModule -> Module () +buildModuleHs m = mkModuleE (cmModule m) [] (genExport c) (genImportInModule c) [] + where + c = cihClass (cmCIH m) + +-- | +buildTopLevelHs :: + String -> + ([ClassModule], [TemplateClassModule]) -> + Module () +buildTopLevelHs modname (mods, tmods) = + mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + where + pkgExtensions = + [ lang + [ "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI" + ] + ] + pkgExports = + map (emodule . cmModule) mods + ++ map emodule [modname <.> "Ordinary", modname <.> "Template", modname <.> "TH"] + pkgImports = genImportInTopLevel modname (mods, tmods) + pkgBody = [] -- map (genTopLevelFFI tih) (filterTLOrdinary tfns) + -- ++ concatMap genTopLevelDef (filterTLOrdinary tfns) + +buildTopLevelOrdinaryHs :: + String -> + ([ClassModule], [TemplateClassModule]) -> + TopLevelImportHeader -> + Module () +buildTopLevelOrdinaryHs modname (_mods, tmods) tih = + mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + where + tfns = tihFuncs tih + pkgExtensions = + [ lang + [ "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI" + ] + ] + pkgExports = map (evar . unqual . hsFrontNameForTopLevel . TLOrdinary) (filterTLOrdinary tfns) + pkgImports = + map mkImport ["Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast"] + ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods + ++ concatMap genImportForTLOrdinary (filterTLOrdinary tfns) + pkgBody = + map (genTopLevelFFI tih) (filterTLOrdinary tfns) + ++ concatMap genTopLevelDef (filterTLOrdinary tfns) + +-- | +buildTopLevelTemplateHs :: + String -> + TopLevelImportHeader -> + Module () +buildTopLevelTemplateHs modname tih = + mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + where + tfns = filterTLTemplate (tihFuncs tih) + pkgExtensions = + [ lang + [ "EmptyDataDecls", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI", + "MultiParamTypeClasses", + "TypeFamilies" + ] + ] + pkgExports = + map + ( (\n -> EThingWith () (EWildcard () 1) n []) + . unqual + . firstUpper + . hsFrontNameForTopLevel + . TLTemplate + ) + tfns + pkgImports = + [ mkImport "Foreign.C.Types", + mkImport "Foreign.Ptr", + mkImport "FFICXX.Runtime.Cast" + ] + ++ concatMap genImportForTLTemplate tfns + pkgBody = concatMap genTLTemplateInterface tfns + +-- | +buildTopLevelTHHs :: + String -> + TopLevelImportHeader -> + Module () +buildTopLevelTHHs modname tih = + mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody + where + tfns = filterTLTemplate (tihFuncs tih) + pkgExtensions = + [ lang + [ "FlexibleContexts", + "FlexibleInstances", + "ForeignFunctionInterface", + "InterruptibleFFI", + "TemplateHaskell" + ] + ] + pkgExports = + map + ( evar + . unqual + . (\x -> "gen" <> x <> "InstanceFor") + . firstUpper + . hsFrontNameForTopLevel + . TLTemplate + ) + tfns + pkgImports = + [ 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" + ] + ++ concatMap genImportForTLTemplate tfns + pkgBody = + concatMap genTLTemplateImplementation tfns + <> concatMap (genTLTemplateInstance tih) 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 --- a/src/FFICXX/Generate/Dependency.hs +++ b/src/FFICXX/Generate/Dependency.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} module FFICXX.Generate.Dependency where @@ -19,50 +20,66 @@ -- 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 Data.Bifunctor (bimap) +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.List as L (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(..) - ) - +import Data.Maybe (catMaybes, fromMaybe, mapMaybe) +import FFICXX.Generate.Name + ( ffiClassName, + getClassModuleBase, + getTClassModuleBase, + hsClassName, + ) +import FFICXX.Generate.Type.Cabal + ( AddCInc, + AddCSrc, + CabalName (..), + cabal_cheaderprefix, + cabal_pkgname, + unCabalName, + ) +import FFICXX.Generate.Type.Class + ( Arg (..), + CPPTypes (..), + Class (..), + DaughterMap, + Function (..), + TLOrdinary (..), + TLTemplate (..), + TemplateAppInfo (..), + TemplateArgType (TArg_Class), + TemplateClass (..), + TemplateFunction (..), + TemplateMemberFunction (..), + TopLevel (..), + Types (..), + Variable (unVariable), + argsFromOpExp, + filterTLOrdinary, + virtualFuncs, + ) +import FFICXX.Generate.Type.Config + ( ModuleUnit (..), + ModuleUnitImports (..), + ModuleUnitMap (..), + emptyModuleUnitImports, + ) +import FFICXX.Generate.Type.Module + ( ClassImportHeader (..), + ClassModule (..), + ClassSubmoduleType (..), + PackageConfig (..), + TemplateClassImportHeader (..), + TemplateClassModule (..), + TemplateClassSubmoduleType (..), + TopLevelImportHeader (..), + UClassSubmodule, + ) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +import System.FilePath ((<.>)) -- utility functions @@ -73,98 +90,91 @@ -- 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 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 _)) = +extractClassFromType (TemplateAppRef (TemplateAppInfo t ps _)) = Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps) -extractClassFromType (TemplateAppMove (TemplateAppInfo t 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 (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) - +class_allparents c = + let ps = class_parents c + in if null ps + then [] + else L.nub (ps <> (concatMap class_allparents ps)) -- | 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 - - + 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 - - +mkDaughterSelfMap = L.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] } - +data Dep4Func = Dep4Func + { returnDependency :: [Either TemplateClass Class], + argumentDependency :: [Either TemplateClass Class] + } -- | extractClassDep :: Function -> Dep4Func -extractClassDep (Constructor args _) = - Dep4Func [] (concatMap classFromArg args) +extractClassDep (Constructor args _) = + Dep4Func [] (concatMap classFromArg args) extractClassDep (Virtual ret _ args _) = - Dep4Func (extractClassFromType ret) (concatMap classFromArg args) + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (NonVirtual ret _ args _) = - Dep4Func (extractClassFromType ret) (concatMap classFromArg args) + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (Static ret _ args _) = - Dep4Func (extractClassFromType ret) (concatMap classFromArg args) + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (Destructor _) = - Dep4Func [] [] + Dep4Func [] [] -- | extractClassDepForTmplFun :: TemplateFunction -> Dep4Func -extractClassDepForTmplFun (TFun ret _ _ args) = - Dep4Func (extractClassFromType ret) (concatMap classFromArg args) +extractClassDepForTmplFun (TFun ret _ _ args) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDepForTmplFun (TFunNew args _) = - Dep4Func [] (concatMap classFromArg args) + Dep4Func [] (concatMap classFromArg args) extractClassDepForTmplFun TFunDelete = - Dep4Func [] [] -extractClassDepForTmplFun (TFunOp ret _ e) = - Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e) + Dep4Func [] [] +extractClassDepForTmplFun (TFunOp ret _ e) = + Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e) -- | extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func @@ -172,140 +182,192 @@ 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 {..} -> [] +extractClassDepForTLOrdinary :: TLOrdinary -> Dep4Func +extractClassDepForTLOrdinary 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 {} -> [] +-- | +extractClassDepForTLTemplate :: TLTemplate -> Dep4Func +extractClassDepForTLTemplate f = + Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) args) + where + ret = topleveltfunc_ret f + args = topleveltfunc_args f --- TODO: Confirm the answer below is correct. --- NOTE: Q: Why returnDependency only? +mkDepFFI :: Class -> [UClassSubmodule] +mkDepFFI cls = + let ps = map Right (class_allparents cls) + alldeps' = concatMap go ps <> go (Right cls) + depSelf = Right (CSTRawType, cls) + in depSelf : (fmap (bimap (TCSTTemplate,) (CSTRawType,)) $ L.nub $ filter (/= Right cls) alldeps') + where + go (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 + go (Left t) = + let fs = tclass_funcs t + in concatMap (returnDependency . extractClassDepForTmplFun) fs + <> concatMap (argumentDependency . extractClassDepForTmplFun) fs + +-- For raws: +-- NOTE: Q: Why returnDependency for RawTypes? -- 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 +calculateDependency :: UClassSubmodule -> [UClassSubmodule] +calculateDependency (Left (typ, tcl)) = raws <> inplaces + where + raws' = + L.nub $ + filter (/= Left tcl) $ + concatMap (returnDependency . extractClassDepForTmplFun) $ + tclass_funcs tcl + raws = + case typ of + TCSTTemplate -> + fmap (bimap (TCSTTemplate,) (CSTRawType,)) raws' + TCSTTH -> + concatMap + ( \case + Left t -> [Left (TCSTTemplate, t)] + Right c -> fmap (Right . (,c)) [CSTRawType, CSTCast, CSTInterface] + ) + raws' + inplaces = + let fs = tclass_funcs tcl + in fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ + L.nub $ + filter (`isInSamePackageButNotInheritedBy` Left tcl) $ + concatMap (argumentDependency . extractClassDepForTmplFun) fs +calculateDependency (Right (CSTRawType, _)) = [] +calculateDependency (Right (CSTFFI, cls)) = mkDepFFI cls +calculateDependency (Right (CSTInterface, cls)) = + let retDepClasses = + concatMap (returnDependency . extractClassDep) (virtualFuncs $ class_funcs cls) + ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs cls) + argDepClasses = + concatMap (argumentDependency . extractClassDep) (virtualFuncs $ class_funcs cls) + ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs cls) + rawSelf = Right (CSTRawType, cls) + raws = + fmap (bimap (TCSTTemplate,) (CSTRawType,)) $ L.nub $ filter (/= Right cls) retDepClasses + exts = + let extclasses = + filter (`isNotInSamePackageWith` Right cls) argDepClasses + parents = map Right (class_parents cls) + in fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ L.nub (parents <> extclasses) + inplaces = + fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ + L.nub $ + filter (`isInSamePackageButNotInheritedBy` Right cls) $ argDepClasses + in rawSelf : (raws ++ exts ++ inplaces) +calculateDependency (Right (CSTCast, cls)) = [Right (CSTRawType, cls), Right (CSTInterface, cls)] +calculateDependency (Right (CSTImplementation, cls)) = + let depsSelf = + [ Right (CSTRawType, cls), + Right (CSTFFI, cls), + Right (CSTInterface, cls), + Right (CSTCast, cls) + ] + dsFFI = fmap (bimap snd snd) $ mkDepFFI cls + dsParents = L.nub $ map Right $ class_allparents cls + dsNonParents = filter (not . (flip elem dsParents)) dsFFI + deps = + concatMap + ( \case + Left t -> [Left (TCSTTemplate, t)] + Right c -> + [ Right (CSTRawType, c), + Right (CSTCast, c), + Right (CSTInterface, c) + ] + ) + (dsNonParents <> dsParents) + in depsSelf <> deps + -- | -isNotInSamePackageWith - :: Either TemplateClass Class - -> Either TemplateClass Class - -> Bool +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 :: + -- | y + Either TemplateClass Class -> + -- | x + Either TemplateClass Class -> + 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 + in L.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 + in L.nub . filter (/= y) $ + concatMap (returnDependency . extractClassDepForTmplFun) fs + <> concatMap (argumentDependency . extractClassDepForTmplFun) fs + <> getparents y --- | -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 _) = [] +-- | Find module-level dependency per each toplevel function/template function. +mkTopLevelDep :: TopLevel -> [UClassSubmodule] +mkTopLevelDep (TLOrdinary f) = + let dep4func = extractClassDepForTLOrdinary f + allDeps = returnDependency dep4func ++ argumentDependency dep4func + mkTags (Left tcl) = [Left (TCSTTemplate, tcl)] + mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface] + in concatMap mkTags allDeps +mkTopLevelDep (TLTemplate f) = + let dep4func = extractClassDepForTLTemplate f + allDeps = returnDependency dep4func ++ argumentDependency dep4func + mkTags (Left tcl) = [Left (TCSTTemplate, tcl)] + mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface] + in concatMap mkTags allDeps -- | -mkClassModule :: (ModuleUnit -> ModuleUnitImports) - -> [(String,[String])] - -> Class - -> ClassModule +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 + ClassModule + { cmModule = getClassModuleBase c, + cmCIH = mkCIH getImports c, + cmImportedSubmodulesForInterface = calculateDependency $ Right (CSTInterface, c), + cmImportedSubmodulesForFFI = calculateDependency $ Right (CSTFFI, c), + cmImportedSubmodulesForCast = calculateDependency $ Right (CSTCast, c), + cmImportedSubmodulesForImplementation = calculateDependency $ Right (CSTImplementation, c), + cmExtraImport = fromMaybe [] (lookup (class_name c) extra) } - 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 @@ -314,121 +376,116 @@ -- | mkTCM :: - TemplateClassImportHeader - -> TemplateClassModule + TemplateClassImportHeader -> + TemplateClassModule mkTCM tcih = let t = tcihTClass tcih - in TCM (getTClassModuleBase t) 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 = +mkPackageConfig :: + -- | (package name,getImports) + (CabalName, ModuleUnit -> ModuleUnitImports) -> + ([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) + cihs = L.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) + 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 + } -- | -mkPkgHeaderFileName ::Class -> HeaderName +mkPkgHeaderFileName :: Class -> HeaderName mkPkgHeaderFileName c = - HdrName ( (cabal_cheaderprefix.class_cabal) c - <> fst (hsClassName c) - <.> "h" - ) + HdrName + ( (cabal_cheaderprefix . class_cabal) c + <> fst (hsClassName c) + <.> "h" + ) -- | -mkPkgCppFileName ::Class -> String +mkPkgCppFileName :: Class -> String mkPkgCppFileName c = - (cabal_cheaderprefix.class_cabal) c - <> fst (hsClassName 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 + let pkgname = (cabal_pkgname . class_cabal) c + extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c + extheaders = L.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 :: + -- | (mk namespace and include headers) + (ModuleUnit -> ModuleUnitImports) -> + 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 - } + 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 :: + 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) + let ofs = filterTLOrdinary fs + tl_cs1 = concatMap (argumentDependency . extractClassDepForTLOrdinary) ofs + tl_cs2 = concatMap (returnDependency . extractClassDepForTLOrdinary) ofs + tl_cs = L.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 + where + fn c ys = + let y = L.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) - } + extheaders = + map HdrName $ + L.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/Dependency/Graph.hs b/src/FFICXX/Generate/Dependency/Graph.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Dependency/Graph.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module FFICXX.Generate.Dependency.Graph where + +import Data.Array (listArray) +import qualified Data.Graph as G +import qualified Data.HashMap.Strict as HM +import qualified Data.List as L +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Tree (flatten) +import Data.Tuple (swap) +import FFICXX.Generate.Dependency + ( calculateDependency, + mkTopLevelDep, + ) +import FFICXX.Generate.Name (subModuleName) +import FFICXX.Generate.Type.Class (TopLevel (..)) +import FFICXX.Generate.Type.Module + ( ClassSubmoduleType (..), + DepCycles, + TemplateClassSubmoduleType (..), + UClass, + UClassSubmodule, + ) + +-- TODO: Introduce unique id per submodule. + +-- | construct dependency graph +constructDepGraph :: + -- | list of all classes, either template class or ordinary class. + [UClass] -> + -- | list of all top-level functions. + [TopLevel] -> + -- | (all submodules, [(submodule, submodule dependencies)]) + ([String], [(Int, [Int])]) +constructDepGraph allClasses allTopLevels = (allSyms, depmap') + where + -- for classes/template classes + mkDep :: UClass -> [(UClassSubmodule, [UClassSubmodule])] + mkDep c = + case c of + Left tcl -> + fmap + (build . Left . (,tcl)) + [TCSTTemplate, TCSTTH] + Right cls -> + fmap + (build . Right . (,cls)) + [CSTRawType, CSTFFI, CSTInterface, CSTCast, CSTImplementation] + where + build x = (x, calculateDependency x) + + dep2Name :: [(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])] + dep2Name = fmap (\(x, ys) -> (subModuleName x, fmap subModuleName ys)) + -- TopLevel + topLevelDeps :: (String, [String]) + topLevelDeps = + let deps = + L.nub . L.sort $ concatMap (fmap subModuleName . mkTopLevelDep) allTopLevels + in ("[TopLevel]", deps) + + depmapAllClasses = concatMap (dep2Name . mkDep) allClasses + depmap = topLevelDeps : depmapAllClasses + allSyms = + L.nub . L.sort $ + fmap fst depmap ++ concatMap snd depmap + allISyms :: [(Int, String)] + allISyms = zip [0 ..] allSyms + symRevMap = HM.fromList $ fmap swap allISyms + replace (c, ds) = do + i <- HM.lookup c symRevMap + js <- traverse (\d -> HM.lookup d symRevMap) ds + pure (i, js) + depmap' = mapMaybe replace depmap + +-- | find grouped dependency cycles +findDepCycles :: ([String], [(Int, [Int])]) -> DepCycles +findDepCycles (syms, deps) = + let symMap = zip [0 ..] syms + lookupSym i = fromMaybe "" (L.lookup i symMap) + n = length syms + bounds = (0, n - 1) + gr = listArray bounds $ fmap (\i -> fromMaybe [] (L.lookup i deps)) [0 .. n - 1] + lookupSymAndRestrictDeps :: [Int] -> [(String, ([String], [String]))] + lookupSymAndRestrictDeps cycl = fmap go cycl + where + go i = + let sym = lookupSym i + (rdepsU, rdepsL) = + L.partition (< i) $ filter (`elem` cycl) $ fromMaybe [] (L.lookup i deps) + (rdepsU', rdepsL') = (fmap lookupSym rdepsU, fmap lookupSym rdepsL) + in (sym, (rdepsU', rdepsL')) + cycleGroups = + fmap lookupSymAndRestrictDeps $ filter (\xs -> length xs > 1) $ fmap flatten (G.scc gr) + in cycleGroups + +getCyclicDepSubmodules :: String -> DepCycles -> ([String], [String]) +getCyclicDepSubmodules self depCycles = fromMaybe ([], []) $ do + cycl <- L.find (\xs -> self `L.elem` fmap fst xs) depCycles + L.lookup self cycl + +-- | locate importing module and imported module in dependency cycles +locateInDepCycles :: (String, String) -> DepCycles -> Maybe (Int, Int) +locateInDepCycles (self, imported) depCycles = do + cycl <- L.find (\xs -> self `L.elem` fmap fst xs) depCycles + let cyclNoDeps = fmap fst cycl + idxSelf <- self `L.elemIndex` cyclNoDeps + idxImported <- imported `L.elemIndex` cyclNoDeps + pure (idxSelf, idxImported) + +gatherHsBootSubmodules :: DepCycles -> [String] +gatherHsBootSubmodules depCycles = do + cycl <- depCycles + (_, (_us, ds)) <- cycl + d <- ds + pure d diff --git a/src/FFICXX/Generate/Name.hs b/src/FFICXX/Generate/Name.hs --- a/src/FFICXX/Generate/Name.hs +++ b/src/FFICXX/Generate/Name.hs @@ -1,33 +1,40 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# 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 ) - +module FFICXX.Generate.Name where +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import FFICXX.Generate.Type.Cabal (cabal_moduleprefix) +import FFICXX.Generate.Type.Class + ( Accessor (..), + Arg (..), + Class (..), + ClassAlias (caFFIName, caHaskellName), + Function (..), + TLOrdinary (..), + TLTemplate (..), + TemplateArgType (..), + TemplateClass (..), + TemplateFunction (..), + TemplateMemberFunction (..), + TopLevel (..), + Variable (..), + ) +import FFICXX.Generate.Type.Module + ( ClassSubmoduleType (..), + TemplateClassSubmoduleType (..), + ) +import FFICXX.Generate.Util (firstLower, toLowers) +import System.FilePath ((<.>)) 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 - + let (x : xs) = case tfn of + TLOrdinary TopLevelFunction {..} -> fromMaybe toplevelfunc_name toplevelfunc_alias + TLOrdinary TopLevelVariable {..} -> fromMaybe toplevelvar_name toplevelvar_alias + TLTemplate TopLevelTemplateFunction {..} -> topleveltfunc_name + in toLower x : xs typeclassName :: Class -> String typeclassName c = 'I' : fst (hsClassName c) @@ -35,97 +42,100 @@ typeclassNameT :: TemplateClass -> String typeclassNameT c = 'I' : fst (hsTemplateClassName c) - - typeclassNameFromStr :: String -> String -typeclassNameFromStr = ('I':) +typeclassNameFromStr = ('I' :) -hsClassName :: Class -> (String, String) -- ^ High-level, 'Raw'-level +hsClassName :: + Class -> + -- | High-level, 'Raw'-level + (String, String) hsClassName c = let cname = maybe (class_name c) caHaskellName (class_alias c) - in (cname, "Raw" <> cname) + 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 :: + TemplateClass -> + -- | High-level, 'Raw'-level + (String, String) hsTemplateClassName t = let tname = tclass_name t - in (tname, "Raw" <> tname) + in (tname, "Raw" <> tname) existConstructorName :: Class -> String -existConstructorName c = 'E' : (fst.hsClassName) c - +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) +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 +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 + 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 + 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 + TFun {tfun_name} -> tfun_name + TFunNew {tfun_new_alias} -> fromMaybe ("new" <> tclass_name t) tfun_new_alias + TFunDelete -> "delete" <> tclass_name t + TFunOp {tfun_name} -> 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 + TFun {tfun_name} -> tfun_name + TFunNew {tfun_new_alias} -> fromMaybe "new" tfun_new_alias + TFunDelete -> "delete" + TFunOp {tfun_name} -> tfun_name cppTmplFuncName :: TemplateFunction -> String cppTmplFuncName f = case f of - TFun {..} -> tfun_name - TFunNew {..} -> "new" - TFunDelete -> "delete" - TFunOp {..} -> tfun_name + TFun {tfun_name} -> tfun_name + TFunNew {} -> "new" + TFunDelete -> "delete" + TFunOp {tfun_name} -> tfun_name -- | accessorName :: Class -> Variable -> Accessor -> String -accessorName c v a = nonvirtualName c (arg_name (unVariable v)) - <> "_" - <> case a of - Getter -> "get" - Setter -> "set" +accessorName c v a = + nonvirtualName c (arg_name (unVariable v)) + <> "_" + <> case a of + Getter -> "get" + Setter -> "set" -- | hscAccessorName :: Class -> Variable -> Accessor -> String @@ -134,7 +144,7 @@ -- | tmplAccessorName :: Variable -> Accessor -> String tmplAccessorName (Variable (Arg _ n)) a = - n <> "_" <> case a of { Getter -> "get"; Setter -> "set" } + n <> "_" <> case a of Getter -> "get"; Setter -> "set" -- | cppStaticName :: Class -> Function -> String @@ -142,19 +152,50 @@ -- | 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 +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 +constructorName c = "new" <> (fst . hsClassName) c nonvirtualName :: Class -> String -> String -nonvirtualName c str = (firstLower.fst.hsClassName) c <> "_" <> str +nonvirtualName c str = (firstLower . fst . hsClassName) c <> "_" <> str destructorName :: String destructorName = "delete" +-- +-- Module base and Submodule names in ClassModule +-- + +getClassModuleBase :: Class -> String +getClassModuleBase = (<.>) <$> (cabal_moduleprefix . class_cabal) <*> (fst . hsClassName) + +getTClassModuleBase :: TemplateClass -> String +getTClassModuleBase = (<.>) <$> (cabal_moduleprefix . tclass_cabal) <*> (fst . hsTemplateClassName) + +subModuleName :: + Either + (TemplateClassSubmoduleType, TemplateClass) + (ClassSubmoduleType, Class) -> + String +subModuleName (Left (typ, tcl)) = modBase <.> submod + where + modBase = getTClassModuleBase tcl + submod = case typ of + TCSTTH -> "TH" + TCSTTemplate -> "Template" +subModuleName (Right (typ, cls)) = modBase <.> submod + where + modBase = getClassModuleBase cls + submod = + case typ of + CSTRawType -> "RawType" + CSTInterface -> "Interface" + CSTImplementation -> "Implementation" + CSTFFI -> "FFI" + CSTCast -> "Cast" diff --git a/src/FFICXX/Generate/QQ/Verbatim.hs b/src/FFICXX/Generate/QQ/Verbatim.hs --- a/src/FFICXX/Generate/QQ/Verbatim.hs +++ b/src/FFICXX/Generate/QQ/Verbatim.hs @@ -1,13 +1,23 @@ module FFICXX.Generate.QQ.Verbatim where -import Language.Haskell.TH.Quote import Language.Haskell.TH.Lib + ( litE, + stringL, + ) +import Language.Haskell.TH.Quote + ( QuasiQuoter (..), + quoteDec, + quoteExp, + quotePat, + quoteType, + ) verbatim :: QuasiQuoter -verbatim = QuasiQuoter{ quoteExp = litE . stringL - , quotePat = undefined - , quoteType = undefined - , quoteDec = undefined - -- , quotePat = litP . stringP - } - +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 --- a/src/FFICXX/Generate/Type/Annotate.hs +++ b/src/FFICXX/Generate/Type/Annotate.hs @@ -2,10 +2,7 @@ import qualified Data.Map as M -data PkgType = PkgModule | PkgClass | PkgMethod - deriving (Show,Eq,Ord) - -type AnnotateMap = M.Map (PkgType,String) String - - +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 --- a/src/FFICXX/Generate/Type/Cabal.hs +++ b/src/FFICXX/Generate/Type/Cabal.hs @@ -2,72 +2,75 @@ module FFICXX.Generate.Type.Cabal where -import Data.Aeson (FromJSON(..),ToJSON(..) - ,genericParseJSON,genericToJSON - ,defaultOptions) +import Data.Aeson + ( FromJSON (..), + ToJSON (..), + defaultOptions, + genericParseJSON, + genericToJSON, + ) import Data.Aeson.Types (fieldLabelModifier) -import Data.Text (Text) -import GHC.Generics (Generic) +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) - +newtype CabalName = CabalName {unCabalName :: String} + deriving (Show, Eq, Ord) -data BuildType = Simple - | Custom [CabalName] -- ^ dependencies +data BuildType + = Simple + | -- | dependencies + Custom [CabalName] -- 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 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) +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} diff --git a/src/FFICXX/Generate/Type/Class.hs b/src/FFICXX/Generate/Type/Class.hs --- a/src/FFICXX/Generate/Type/Class.hs +++ b/src/FFICXX/Generate/Type/Class.hs @@ -1,21 +1,18 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# 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 ) - +import Data.List (intercalate) +import qualified Data.Map as M +import Data.Maybe (mapMaybe) +import FFICXX.Generate.Type.Cabal (Cabal) -- | C types -data CTypes = - CTBool +data CTypes + = CTBool | CTChar | CTClock | CTDouble @@ -57,121 +54,143 @@ | CEnum CTypes String | CPointer CTypes | CRef CTypes - deriving Show + deriving (Show) -- | C++ types -data CPPTypes = CPTClass Class - | CPTClassRef Class - | CPTClassCopy Class - | CPTClassMove Class - deriving Show +data CPPTypes + = CPTClass Class + | CPTClassRef Class + | CPTClassCopy Class + | CPTClassMove Class + deriving (Show) -- | const flag data IsConst = Const | NoConst - deriving Show + 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 +data TemplateArgType + = TArg_Class Class | TArg_TypeParam String | TArg_Other String - deriving Show + deriving (Show) -data TemplateAppInfo = - TemplateAppInfo { - tapp_tclass :: TemplateClass - , tapp_tparams :: [TemplateArgType] - , tapp_CppTypeForParam :: String -- TODO: remove this +data TemplateAppInfo = TemplateAppInfo + { tapp_tclass :: TemplateClass, + tapp_tparams :: [TemplateArgType], + tapp_CppTypeForParam :: String -- TODO: remove this } - deriving Show + deriving (Show) -- | Supported C++ types. -data Types = - Void +data Types + = Void | SelfType - | CT CTypes IsConst + | 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 + | -- | like vector* + TemplateApp TemplateAppInfo + | -- | like vector& + TemplateAppRef TemplateAppInfo + | -- | like unique_ptr (using std::move) + TemplateAppMove TemplateAppInfo + | -- | template self? TODO: clarify this. + TemplateType TemplateClass + | TemplateParam String + | -- | this is A* with template + TemplateParamPointer String + deriving (Show) ------------- -- | Function argument, type and variable name. -data Arg = - Arg { - arg_type :: Types - , arg_name :: String +data Arg = Arg + { arg_type :: Types, + arg_name :: String } - deriving Show + 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 +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 +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 +data TemplateMemberFunction = TemplateMemberFunction + { tmf_params :: [String], + tmf_ret :: Types, + tmf_name :: String, + tmf_args :: [Arg], + tmf_alias :: Maybe String } - deriving Show + 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 +data TopLevel + = TLOrdinary TLOrdinary + | TLTemplate TLTemplate + deriving (Show) +filterTLOrdinary :: [TopLevel] -> [TLOrdinary] +filterTLOrdinary = mapMaybe (\case TLOrdinary f -> Just f; _ -> Nothing) + +filterTLTemplate :: [TopLevel] -> [TLTemplate] +filterTLTemplate = mapMaybe (\case TLTemplate f -> Just f; _ -> Nothing) + +data TLOrdinary + = 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) + +data TLTemplate = TopLevelTemplateFunction + { topleveltfunc_params :: [String], + topleveltfunc_ret :: Types, + topleveltfunc_name :: String, + topleveltfunc_oname :: String, + topleveltfunc_args :: [Arg] + } + deriving (Show) + isNewFunc :: Function -> Bool isNewFunc (Constructor _ _) = True isNewFunc _ = False @@ -181,15 +200,13 @@ isDeleteFunc _ = False isVirtualFunc :: Function -> Bool -isVirtualFunc (Destructor _) = True -isVirtualFunc (Virtual _ _ _ _) = True -isVirtualFunc _ = False +isVirtualFunc (Destructor _) = True +isVirtualFunc (Virtual _ _ _ _) = True +isVirtualFunc _ = False isNonVirtualFunc :: Function -> Bool isNonVirtualFunc (NonVirtual _ _ _ _) = True -isNonVirtualFunc _ = False - - +isNonVirtualFunc _ = False isStaticFunc :: Function -> Bool isStaticFunc (Static _ _ _ _) = True @@ -203,42 +220,44 @@ nonVirtualNotNewFuncs :: [Function] -> [Function] nonVirtualNotNewFuncs = - filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x ) + 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) +newtype ProtectedMethod = Protected {unProtected :: [String]} + deriving (Semigroup, Monoid) -data ClassAlias = ClassAlias { caHaskellName :: String - , caFFIName :: String - } +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] - } +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 @@ -252,55 +271,62 @@ 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 OpExp + = -- | unary * (deRef) operator + OpStar + | -- | unary prefix ++ operator + -- | OpAdd Arg Arg + -- | OpMul Arg Arg + OpFPPlus -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 - } +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 - } + | TFunOp + { tfun_ret :: Types, + -- | haskell alias for the operator + tfun_name :: String, + tfun_opexp :: OpExp + } argsFromOpExp :: OpExp -> [Arg] -argsFromOpExp OpStar = [] +argsFromOpExp OpStar = [] argsFromOpExp OpFPPlus = [] + -- argsFromOpExp (OpAdd x y) = [x,y] -- argsFromOpExp (OpMul x y) = [x,y] opSymbol :: OpExp -> String -opSymbol OpStar = "*" +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 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] +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 @@ -315,27 +341,24 @@ instance Ord TemplateClass where compare x y = compare (tclass_name x) (tclass_name y) - data ClassGlobal = ClassGlobal - { cgDaughterSelfMap :: DaughterMap - , cgDaughterMap :: DaughterMap - } + { cgDaughterSelfMap :: DaughterMap, + cgDaughterMap :: DaughterMap + } data Selfness = Self | NoSelf - - -- | Check abstract class isAbstractClass :: Class -> Bool -isAbstractClass Class{} = False -isAbstractClass AbstractClass{} = True +isAbstractClass Class {} = False +isAbstractClass AbstractClass {} = True -- | Check having Proxy hasProxy :: Class -> Bool -hasProxy c@Class{} = class_has_proxy c -hasProxy AbstractClass{} = False +hasProxy c@Class {} = class_has_proxy c +hasProxy AbstractClass {} = False type DaughterMap = M.Map String [Class] data Accessor = Getter | Setter - deriving (Show, Eq) + deriving (Show, Eq) diff --git a/src/FFICXX/Generate/Type/Config.hs b/src/FFICXX/Generate/Type/Config.hs --- a/src/FFICXX/Generate/Type/Config.hs +++ b/src/FFICXX/Generate/Type/Config.hs @@ -1,39 +1,39 @@ {-# LANGUAGE DeriveGeneric #-} + module FFICXX.Generate.Type.Config where -import Data.Hashable ( Hashable(..) ) -import Data.HashMap.Strict ( HashMap ) -import GHC.Generics ( Generic ) +import Data.HashMap.Strict (HashMap) +import Data.Hashable (Hashable (..)) -- -import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..), Namespace(..) ) - +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) +import GHC.Generics (Generic) -data ModuleUnit = MU_TopLevel - | MU_Class String - deriving (Show,Eq,Generic) +data ModuleUnit + = MU_TopLevel + | MU_Class String + deriving (Show, Eq, Generic) instance Hashable ModuleUnit -data ModuleUnitImports = - ModuleUnitImports { - muimports_namespaces :: [Namespace] - , muimports_headers :: [HeaderName] +data ModuleUnitImports = ModuleUnitImports + { muimports_namespaces :: [Namespace], + muimports_headers :: [HeaderName] } deriving (Show) emptyModuleUnitImports = ModuleUnitImports [] [] -newtype ModuleUnitMap = ModuleUnitMap { unModuleUnitMap :: HashMap ModuleUnit ModuleUnitImports } +newtype ModuleUnitMap = ModuleUnitMap {unModuleUnitMap :: HashMap ModuleUnit ModuleUnitImports} modImports :: - String - -> [String] - -> [HeaderName] - -> (ModuleUnit,ModuleUnitImports) + String -> + [String] -> + [HeaderName] -> + (ModuleUnit, ModuleUnitImports) modImports n ns hs = - ( MU_Class n - , ModuleUnitImports { - muimports_namespaces = map NS ns - , muimports_headers = 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 --- a/src/FFICXX/Generate/Type/Module.hs +++ b/src/FFICXX/Generate/Type/Module.hs @@ -1,80 +1,113 @@ 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 ) - +import FFICXX.Generate.Type.Cabal (AddCInc, AddCSrc) +import FFICXX.Generate.Type.Class (Class, TemplateClass, TopLevel) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..), Namespace (..)) --- | C++ side +-- +-- Import/Header +-- -- 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) +data ClassImportHeader = ClassImportHeader + { cihClass :: Class, + -- | fficxx-side main header + cihSelfHeader :: HeaderName, + cihNamespace :: [Namespace], + cihSelfCpp :: String, + -- | Dependencies TODO: clarify this. + cihImportedClasses :: [Either TemplateClass Class], + cihIncludedHPkgHeadersInH :: [HeaderName], -- TODO: Explain why we need to have these two + cihIncludedHPkgHeadersInCPP :: [HeaderName], -- separately. + -- | C++-side headers + cihIncludedCPkgHeaders :: [HeaderName] + } + deriving (Show) -------------------------- --- Haskell side module -- -------------------------- +-- +-- Submodule +-- -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 ClassSubmoduleType + = CSTRawType + | CSTInterface + | CSTImplementation + | CSTFFI + | CSTCast + deriving (Show) +data TemplateClassSubmoduleType + = TCSTTH + | TCSTTemplate + deriving (Show) -data TemplateClassModule = - TCM { - tcmModule :: String - , tcmTCIH :: TemplateClassImportHeader - } deriving (Show) +-- | UClass = Unified Class, either template class or ordinary class +type UClass = Either TemplateClass Class +type UClassSubmodule = + Either (TemplateClassSubmoduleType, TemplateClass) (ClassSubmoduleType, Class) -data TemplateClassImportHeader = - TCIH { - tcihTClass :: TemplateClass - , tcihCxxHeaders :: [HeaderName] -- ^ C++-side headers - } deriving (Show) +-- | Dependency cycle information. Currently just a string +-- self, former, latter +type DepCycles = [[(String, ([String], [String]))]] -data TopLevelImportHeader = - TopLevelImportHeader { - tihHeaderFileName :: String - , tihClassDep :: [ClassImportHeader] - , tihExtraClassDep :: [Either TemplateClass Class] - -- ^ Extra class dependencies outside current package. +-- +-- Module +-- + +data ClassModule = ClassModule + { cmModule :: String, + cmCIH :: ClassImportHeader, + -- | imported submodules for Interface.hs + cmImportedSubmodulesForInterface :: [UClassSubmodule], + -- | imported submodules for FFI.hs + cmImportedSubmodulesForFFI :: [UClassSubmodule], + -- | imported submodules for Cast.hs + cmImportedSubmodulesForCast, + -- imported submodules for Implementation.hs + cmImportedSubmodulesForImplementation :: + [UClassSubmodule], + cmExtraImport :: [String] + } + deriving (Show) + +data TemplateClassModule = TCM + { tcmModule :: String, + tcmTCIH :: TemplateClassImportHeader + } + deriving (Show) + +data TemplateClassImportHeader = TCIH + { tcihTClass :: TemplateClass, + -- | C++-side headers + tcihCxxHeaders :: [HeaderName] + } + deriving (Show) + +data TopLevelImportHeader = TopLevelImportHeader + { tihHeaderFileName :: String, + tihClassDep :: [ClassImportHeader], + -- | Extra class dependencies outside current package. -- NOTE: we cannot fully construct ClassImportHeader for them. - , tihFuncs :: [TopLevel] - , tihNamespaces :: [Namespace] - , tihExtraHeadersInH :: [HeaderName] - , tihExtraHeadersInCPP :: [HeaderName] - } deriving (Show) + tihExtraClassDep :: [Either TemplateClass Class], + 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] +-- +-- Package-level +-- + +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 --- a/src/FFICXX/Generate/Type/PackageInterface.hs +++ b/src/FFICXX/Generate/Type/PackageInterface.hs @@ -1,15 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -- TODO: remove this module -module FFICXX.Generate.Type.PackageInterface where +module FFICXX.Generate.Type.PackageInterface where -import Data.Hashable ( Hashable ) import qualified Data.HashMap.Strict as HM +import Data.Hashable (Hashable) -- -import FFICXX.Runtime.CodeGen.Cxx ( HeaderName(..) ) +import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..)) +newtype PackageName = PkgName String deriving (Hashable, Show, Eq, Ord) -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 +type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName diff --git a/src/FFICXX/Generate/Util.hs b/src/FFICXX/Generate/Util.hs --- a/src/FFICXX/Generate/Util.hs +++ b/src/FFICXX/Generate/Util.hs @@ -2,23 +2,24 @@ 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 --- +import Data.Char (toLower, toUpper) +import Data.List (intercalate) +import Data.List.Split (splitOn) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Data.Text.Template + ( Context, + substitute, + ) -moduleDirFile :: String -> (String,String) -moduleDirFile mname = +moduleDirFile :: String -> (String, String) +moduleDirFile mname = let splitted = splitOn "." mname - moddir = intercalate "/" (init splitted ) - modfile = (last splitted) <> ".hs" - in (moddir, modfile) + moddir = intercalate "/" (init splitted) + modfile = (last splitted) <> ".hs" + in (moddir, modfile) hline :: IO () hline = putStrLn "--------------------------------------------------------" @@ -26,24 +27,27 @@ toUppers :: String -> String toUppers = map toUpper -toLowers :: String -> String +toLowers :: String -> String toLowers = map toLower +firstLower :: String -> String +firstLower [] = [] +firstLower (x : xs) = (toLower x) : xs -firstLower :: String -> String -firstLower [] = [] -firstLower (x:xs) = (toLower x) : xs +firstUpper :: String -> String +firstUpper [] = [] +firstUpper (x : xs) = (toUpper x) : xs -conn :: String -> String -> String -> String -conn st x y = x <> st <> y +conn :: String -> String -> String -> String +conn st x y = x <> st <> y connspace :: String -> String -> String -connspace = conn " " +connspace = conn " " conncomma :: String -> String -> String -conncomma = conn ", " +conncomma = conn ", " -connBSlash :: String -> String -> String +connBSlash :: String -> String -> String connBSlash = conn "\\\n" connSemicolonBSlash :: String -> String -> String @@ -52,35 +56,36 @@ connRet :: String -> String -> String connRet = conn "\n" -connRet2 :: String -> String -> String +connRet2 :: String -> String -> String connRet2 = conn "\n\n" -connArrow :: String -> String -> String -connArrow = conn " -> " +connArrow :: String -> String -> String +connArrow = conn " -> " -intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String -intercalateWith f mapper x +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 "" + | 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 :: [(Text, String)] -> Context context assocs x = maybe err (T.pack) . lookup x $ assocs - where err = error $ "Could not find key: " <> (T.unpack x) + where + err = error $ "Could not find key: " <> (T.unpack x) -- TODO: Rename this to context. -- TODO: Proper error handling. -contextT :: [(Text,Text)] -> Context +contextT :: [(Text, Text)] -> Context contextT assocs x = fromMaybe err . lookup x $ assocs - where err = error $ T.unpack ("Could not find key: " <> x) + 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/DepGraph.hs b/src/FFICXX/Generate/Util/DepGraph.hs new file mode 100644 --- /dev/null +++ b/src/FFICXX/Generate/Util/DepGraph.hs @@ -0,0 +1,36 @@ +module FFICXX.Generate.Util.DepGraph + ( drawDepGraph, + ) +where + +import Data.Foldable (for_) +import FFICXX.Generate.Dependency.Graph + ( constructDepGraph, + ) +import FFICXX.Generate.Type.Class (TopLevel (..)) +import FFICXX.Generate.Type.Module (UClass) +import Text.Dot (Dot, NodeId, attribute, node, showDot, (.->.)) + +src, box, diamond :: String -> Dot NodeId +src label = node $ [("shape", "none"), ("label", label)] +box label = node $ [("shape", "box"), ("style", "rounded"), ("label", label)] +diamond label = node $ [("shape", "diamond"), ("label", label), ("fontsize", "10")] + +-- | Draw dependency graph of modules in graphviz dot format. +drawDepGraph :: + -- | list of all classes, either template class or ordinary class. + [UClass] -> + -- | list of all top-level functions. + [TopLevel] -> + -- | dot string + String +drawDepGraph allclasses allTopLevels = + showDot $ do + attribute ("size", "40,15") + attribute ("rankdir", "LR") + cs <- traverse box allSyms + for_ depmap' $ \(i, js) -> + for_ js $ \j -> + (cs !! i) .->. (cs !! j) + where + (allSyms, depmap') = constructDepGraph allclasses allTopLevels diff --git a/src/FFICXX/Generate/Util/HaskellSrcExts.hs b/src/FFICXX/Generate/Util/HaskellSrcExts.hs --- a/src/FFICXX/Generate/Util/HaskellSrcExts.hs +++ b/src/FFICXX/Generate/Util/HaskellSrcExts.hs @@ -1,14 +1,112 @@ -{-# 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) - +import Data.List (foldl') +import Data.Maybe (maybeToList) +import Language.Haskell.Exts + ( Alt (..), + Asst (TypeA), + Binds, + Bracket (TypeBracket), + CallConv (CCall), + ClassDecl (ClsDecl), + ConDecl + ( ConDecl, + RecDecl + ), + Context + ( CxEmpty, + CxTuple + ), + DataOrNew + ( DataType, + NewType + ), + Decl + ( ClassDecl, + DataDecl, + ForImp, + FunBind, + InstDecl, + PatBind, + TypeSig + ), + DeclHead + ( DHApp, + DHead + ), + Deriving (..), + EWildcard (..), + Exp + ( App, + BracketExp, + Con, + If, + InfixApp, + Lit, + Var + ), + ExportSpec + ( EAbs, + EModuleContents, + EThingWith, + EVar + ), + ExportSpecList (..), + FieldDecl, + ImportDecl (..), + ImportSpec (IVar), + ImportSpecList (..), + InstDecl + ( InsDecl, + InsType + ), + InstHead + ( IHApp, + IHCon + ), + InstRule (IRule), + Literal, + Match (..), + Module (..), + ModuleHead (..), + ModuleName (..), + ModulePragma (LanguagePragma), + Name + ( Ident, + Symbol + ), + Namespace (NoNamespace), + Pat + ( PVar, + PatTypeSig + ), + QName (UnQual), + QOp (QVarOp), + QualConDecl (..), + Rhs (UnGuardedRhs), + Safety (PlayInterruptible), + Splice (ParenSplice), + Stmt + ( Generator, + Qualifier + ), + TyVarBind (UnkindedVar), + Type + ( TyApp, + TyCon, + TyForall, + TyFun, + TyList, + TyParen, + TySplice, + TyVar + ), + app, + unit_tycon, + ) +import Language.Haskell.Exts.Syntax (CName) -unqual :: String -> QName () +unqual :: String -> QName () unqual = UnQual () . Ident () tycon :: String -> Type () @@ -33,6 +131,11 @@ conDecl :: String -> [Type ()] -> ConDecl () conDecl n ys = ConDecl () (Ident () n) ys +qualConDecl :: + Maybe [TyVarBind ()] -> + Maybe (Context ()) -> + ConDecl () -> + QualConDecl () qualConDecl = QualConDecl () recDecl :: String -> [FieldDecl ()] -> ConDecl () @@ -41,11 +144,9 @@ app' :: String -> String -> Exp () app' x y = App () (mkVar x) (mkVar y) - lit :: Literal () -> Exp () lit = Lit () - mkVar :: String -> Exp () mkVar = Var () . unqual @@ -75,7 +176,7 @@ mkBind1 :: String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl () mkBind1 n pat rhs mbinds = - FunBind () [ Match () (Ident () n) pat (UnGuardedRhs () 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] @@ -84,8 +185,7 @@ 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) - +mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just cdecls) dhead :: String -> DeclHead () dhead n = DHead () (Ident () n) @@ -95,37 +195,35 @@ 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) + 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 +mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv) + 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 +mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv) + where + declhead = mkDeclHead n tbinds mkForImpCcall :: String -> String -> Type () -> Decl () -mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlaySafe () False)) (Just quote) (Ident () n) typ +mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlayInterruptible ())) (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 + 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 +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 @@ -133,8 +231,8 @@ mkImportExp :: String -> [String] -> ImportDecl () mkImportExp m lst = ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist) - where islist = ImportSpecList () False (map mkIVar lst) - + where + islist = ImportSpecList () False (map mkIVar lst) mkImportSrc :: String -> ImportDecl () mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing @@ -145,8 +243,14 @@ dot :: Exp () -> Exp () -> Exp () x `dot` y = x `app` mkVar "." `app` y +tyForall :: + Maybe [TyVarBind ()] -> + Maybe (Context ()) -> + Type () -> + Type () tyForall = TyForall () +tyParen :: Type () -> Type () tyParen = TyParen () tyPtr :: Type () @@ -156,11 +260,7 @@ 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 () @@ -174,50 +274,77 @@ parenSplice :: Exp () -> Splice () parenSplice = ParenSplice () +bracketExp :: Bracket () -> Exp () bracketExp = BracketExp () -typeBracket = TypeBracket () +typeBracket :: Type () -> Bracket () +typeBracket = TypeBracket () -#if MIN_VERSION_haskell_src_exts(1,20,0) +mkDeriving :: [InstRule ()] -> Deriving () mkDeriving = Deriving () Nothing -#else -mkDeriving = Deriving () -#endif +irule :: + Maybe [TyVarBind ()] -> + Maybe (Context ()) -> + InstHead () -> + InstRule () irule = IRule () +ihcon :: QName () -> InstHead () ihcon = IHCon () +evar :: QName () -> ExportSpec () evar = EVar () + +eabs :: Namespace () -> QName () -> ExportSpec () eabs = EAbs () + +ethingwith :: + EWildcard () -> + QName () -> + [Language.Haskell.Exts.Syntax.CName ()] -> + ExportSpec () ethingwith = EThingWith () +ethingall :: QName () -> ExportSpec () ethingall q = ethingwith (EWildcard () 0) q [] +emodule :: String -> ExportSpec () emodule nm = EModuleContents () (ModuleName () nm) +nonamespace :: Namespace () nonamespace = NoNamespace () +insType :: Type () -> Type () -> InstDecl () insType = InsType () +insDecl :: Decl () -> InstDecl () insDecl = InsDecl () +generator :: Pat () -> Exp () -> Stmt () generator = Generator () +qualifier :: Exp () -> Stmt () qualifier = Qualifier () +clsDecl :: Decl () -> ClassDecl () clsDecl = ClsDecl () - +unkindedVar :: Name () -> TyVarBind () unkindedVar = UnkindedVar () +op :: String -> QOp () op = QVarOp () . UnQual () . Symbol () +inapp :: Exp () -> QOp () -> Exp () -> Exp () inapp = InfixApp () +if_ :: Exp () -> Exp () -> Exp () -> Exp () if_ = If () +urhs :: Exp () -> Rhs () urhs = UnGuardedRhs () --- case pattern match p -> e +-- | case pattern match p -> e +match :: Pat () -> Exp () -> Alt () match p e = Alt () p (urhs e) Nothing