fficxx 0.5.1 → 0.6

raw patch · 46 files changed

+5280/−4604 lines, 46 filesdep +fficxx-runtimesetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: fficxx-runtime

API changes (from Hackage documentation)

Files

• LICENSE +1/−1
• Setup.lhs +0/−10
• fficxx.cabal +33/−34
• lib/FFICXX/Generate/Builder.hs +0/−267
• lib/FFICXX/Generate/Code/Cabal.hs +0/−291
• lib/FFICXX/Generate/Code/Cpp.hs +0/−490
• lib/FFICXX/Generate/Code/HsCast.hs +0/−37
• lib/FFICXX/Generate/Code/HsFFI.hs +0/−104
• lib/FFICXX/Generate/Code/HsFrontEnd.hs +0/−334
• lib/FFICXX/Generate/Code/HsTemplate.hs +0/−180
• lib/FFICXX/Generate/Code/Primitive.hs +0/−882
• lib/FFICXX/Generate/Config.hs +0/−39
• lib/FFICXX/Generate/ContentMaker.hs +0/−485
• lib/FFICXX/Generate/Dependency.hs +0/−430
• lib/FFICXX/Generate/Name.hs +0/−140
• lib/FFICXX/Generate/QQ/Verbatim.hs +0/−25
• lib/FFICXX/Generate/Type/Annotate.hs +0/−23
• lib/FFICXX/Generate/Type/Cabal.hs +0/−88
• lib/FFICXX/Generate/Type/Class.hs +0/−295
• lib/FFICXX/Generate/Type/Config.hs +0/−25
• lib/FFICXX/Generate/Type/Module.hs +0/−76
• lib/FFICXX/Generate/Type/PackageInterface.hs +0/−36
• lib/FFICXX/Generate/Util.hs +0/−99
• lib/FFICXX/Generate/Util/HaskellSrcExts.hs +0/−213
• src/FFICXX/Generate/Builder.hs +264/−0
• src/FFICXX/Generate/Code/Cabal.hs +283/−0
• src/FFICXX/Generate/Code/Cpp.hs +711/−0
• src/FFICXX/Generate/Code/HsCast.hs +37/−0
• src/FFICXX/Generate/Code/HsFFI.hs +111/−0
• src/FFICXX/Generate/Code/HsFrontEnd.hs +322/−0
• src/FFICXX/Generate/Code/HsProxy.hs +37/−0
• src/FFICXX/Generate/Code/HsTemplate.hs +440/−0
• src/FFICXX/Generate/Code/Primitive.hs +1006/−0
• src/FFICXX/Generate/Config.hs +26/−0
• src/FFICXX/Generate/ContentMaker.hs +531/−0
• src/FFICXX/Generate/Dependency.hs +434/−0
• src/FFICXX/Generate/Name.hs +160/−0
• src/FFICXX/Generate/QQ/Verbatim.hs +13/−0
• src/FFICXX/Generate/Type/Annotate.hs +11/−0
• src/FFICXX/Generate/Type/Cabal.hs +76/−0
• src/FFICXX/Generate/Type/Class.hs +341/−0
• src/FFICXX/Generate/Type/Config.hs +39/−0
• src/FFICXX/Generate/Type/Module.hs +80/−0
• src/FFICXX/Generate/Type/PackageInterface.hs +15/−0
• src/FFICXX/Generate/Util.hs +86/−0
• src/FFICXX/Generate/Util/HaskellSrcExts.hs +223/−0

@@ -1,7 +1,7 @@ The following license covers this documentation, and the source code, except where otherwise indicated. -Copyright 2011-2013, Ian-Woo Kim. All rights reserved.+Copyright 2011-2019, Ian-Woo Kim. All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

@@ -1,10 +0,0 @@-#! /usr/bin/env runhaskell--> import Distribution.Simple-> import Distribution.PackageDescription-> --import System.Process-> main = defaultMain-> --main = defaultMainWithHooks testUserHooks-> --testUserHooks = simpleUserHooks { ->  --   preConf = \_ _ -> runCommand "cd rootcode; make; cd .." >>return emptyHookedBuildInfo->   --  } 

@@ -1,21 +1,22 @@ Name:           fficxx-Version:        0.5.1-Synopsis:       automatic C++ binding generation-Description:    automatic C++ binding generation+Version:        0.6+Synopsis:       Automatic C++ binding generation+Description:    fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++. License:        BSD3 License-file:   LICENSE Author:         Ian-Woo Kim Maintainer:     Ian-Woo Kim <ianwookim@gmail.com> Build-Type:     Simple Category:       FFI Tools-Cabal-Version:  >= 1.8+Cabal-Version:  >= 1.10  Source-repository head   type: git   location: http://www.github.com/wavewave/fficxx  Library-  hs-source-dirs: lib+  hs-source-dirs: src+  default-language: Haskell2010     Build-Depends: base == 4.*                , aeson                , aeson-pretty@@ -26,6 +27,7 @@                , directory                , either                , errors+               , fficxx-runtime                , filepath>1                , hashable                , haskell-src-exts >= 1.18@@ -39,33 +41,30 @@                , template-haskell                , text                , unordered-containers--   Exposed-Modules:-                   FFICXX.Generate.Builder-                   FFICXX.Generate.Config-                   FFICXX.Generate.Code.Cpp-                   FFICXX.Generate.Code.HsCast-                   FFICXX.Generate.Code.HsFrontEnd-                   FFICXX.Generate.Code.HsFFI-                   FFICXX.Generate.Code.HsTemplate-                   FFICXX.Generate.Code.Cabal-                   FFICXX.Generate.Code.Primitive-                   FFICXX.Generate.ContentMaker-                   FFICXX.Generate.Dependency-                   FFICXX.Generate.Name-                   FFICXX.Generate.QQ.Verbatim-                   FFICXX.Generate.Util-                   FFICXX.Generate.Util.HaskellSrcExts-                   FFICXX.Generate.Type.Annotate-                   FFICXX.Generate.Type.Cabal-                   FFICXX.Generate.Type.Config-                   FFICXX.Generate.Type.Class-                   FFICXX.Generate.Type.Module-                   FFICXX.Generate.Type.PackageInterface-  ghc-options:     -Wall-                   -funbox-strict-fields-                   -fno-warn-unused-do-bind-                   -fno-warn-missing-signatures-                   -O2-  ghc-prof-options: -caf-all -auto-all+               FFICXX.Generate.Builder+               FFICXX.Generate.Config+               FFICXX.Generate.Code.Cpp+               FFICXX.Generate.Code.HsCast+               FFICXX.Generate.Code.HsFFI+               FFICXX.Generate.Code.HsFrontEnd+               FFICXX.Generate.Code.HsProxy+               FFICXX.Generate.Code.HsTemplate+               FFICXX.Generate.Code.Cabal+               FFICXX.Generate.Code.Primitive+               FFICXX.Generate.ContentMaker+               FFICXX.Generate.Dependency+               FFICXX.Generate.Name+               FFICXX.Generate.QQ.Verbatim+               FFICXX.Generate.Util+               FFICXX.Generate.Util.HaskellSrcExts+               FFICXX.Generate.Type.Annotate+               FFICXX.Generate.Type.Cabal+               FFICXX.Generate.Type.Config+               FFICXX.Generate.Type.Class+               FFICXX.Generate.Type.Module+               FFICXX.Generate.Type.PackageInterface+  ghc-options: -Wall+               -funbox-strict-fields+               -fno-warn-unused-do-bind+               -fno-warn-missing-signatures

@@ -1,267 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Builder--- Copyright   : (c) 2011-2019 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Builder where--import           Control.Monad                           ( void, when )-import qualified Data.ByteString.Lazy.Char8        as L-import           Data.Char                               ( toUpper )-import           Data.Digest.Pure.MD5                    ( md5 )-import           Data.Foldable                           ( for_ )-import           Data.Monoid                             ( (<>), mempty )-import           Language.Haskell.Exts.Pretty            ( prettyPrint )-import           System.FilePath                         ( (</>), (<.>), splitExtension )-import           System.Directory                        ( copyFile-                                                         , createDirectoryIfMissing-                                                         , doesFileExist-                                                         )-import           System.IO                               ( hPutStrLn, withFile, IOMode(..) )-import           System.Process                          ( readProcess )----import           FFICXX.Generate.Code.Cabal-import           FFICXX.Generate.Dependency-import           FFICXX.Generate.Config                  ( FFICXXConfig(..)-                                                         , SimpleBuilderConfig(..)-                                                         )-import           FFICXX.Generate.ContentMaker-import           FFICXX.Generate.Type.Cabal              ( Cabal(..)-                                                         , CabalName(..)-                                                         , AddCInc(..)-                                                         , AddCSrc(..)-                                                         )-import           FFICXX.Generate.Type.Module-import           FFICXX.Generate.Type.PackageInterface-import           FFICXX.Generate.Util-----macrofy :: String -> String-macrofy = map ((\x->if x=='-' then '_' else x) . toUpper)---simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO ()-simpleBuilder cfg sbc = do-  putStrLn "----------------------------------------------------"-  putStrLn "-- fficxx code generation for Haskell-C++ binding --"-  putStrLn "----------------------------------------------------"-  let SimpleBuilderConfig-        topLevelMod-        mumap-        cabal-        classes-        toplevelfunctions-        templates-        extralibs-        extramods-        staticFiles-        = sbc-      pkgname = cabal_pkgname cabal-  putStrLn ("Generating " <> unCabalName pkgname)-  let workingDir = fficxxconfig_workingDir cfg-      installDir = fficxxconfig_installBaseDir cfg-      staticDir  = fficxxconfig_staticFileDir cfg--      pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) =-        mkPackageConfig-          (pkgname, findModuleUnitImports mumap)-          (classes, toplevelfunctions,templates,extramods)-          (cabal_additional_c_incs cabal)-          (cabal_additional_c_srcs cabal)-      hsbootlst = mkHSBOOTCandidateList mods-      cabalFileName = unCabalName pkgname <.> "cabal"-      jsonFileName = unCabalName pkgname <.> "json"-  ---  createDirectoryIfMissing True workingDir-  createDirectoryIfMissing True installDir-  createDirectoryIfMissing True (installDir </> "src")-  createDirectoryIfMissing True (installDir </> "csrc")-  ---  putStrLn "Copying static files"-  mapM_ (\x->copyFileWithMD5Check (staticDir </> x) (installDir </> x)) staticFiles-  ---  putStrLn "Generating Cabal file"-  buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDir</>cabalFileName)-  ---  putStrLn "Generating JSON file"-  buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDir</>jsonFileName)-  ---  putStrLn "Generating Header file"-  let typmacro = TypMcro ("__"  <> macrofy (unCabalName (cabal_pkgname cabal)) <> "__")-      gen :: FilePath -> String -> IO ()-      gen file str =-        let path = workingDir </> file in withFile path WriteMode (flip hPutStrLn str)---  gen (unCabalName pkgname <> "Type.h") (buildTypeDeclHeader typmacro (map cihClass cihs))-  for_ cihs $ \hdr -> gen-                        (unHdrName (cihSelfHeader hdr))-                        (buildDeclHeader typmacro (unCabalName pkgname) hdr)-  gen-    (tihHeaderFileName tih <.> "h")-    (buildTopLevelHeader typmacro (unCabalName pkgname) tih)-  for_ tcms $ \m ->-    let tcihs = tcmTCIH m-    in for_ tcihs $ \tcih ->-         let t = tcihTClass tcih-             hdr = unHdrName (tcihSelfHeader tcih)-         in gen hdr (buildTemplateHeader typmacro t)-  ---  putStrLn "Generating Cpp file"-  for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr))-  gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih)-  ---  putStrLn "Generating Additional Header/Source"-  for_ (cabal_additional_c_incs cabal) (\(AddCInc hdr txt) -> gen hdr txt)-  for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt)-  ---  putStrLn "Generating RawType.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "RawType" <.> "hs")-                      (prettyPrint (buildRawTypeHs m))-  ---  putStrLn "Generating FFI.hsc"-  for_ mods $ \m -> gen-                      (cmModule m <.> "FFI" <.> "hsc")-                      (prettyPrint (buildFFIHsc m))-  ---  putStrLn "Generating Interface.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "Interface" <.> "hs")-                      (prettyPrint (buildInterfaceHs mempty m))-  ---  putStrLn "Generating Cast.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "Cast" <.> "hs")-                      (prettyPrint (buildCastHs m))-  ---  putStrLn "Generating Implementation.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "Implementation" <.> "hs")-                      (prettyPrint (buildImplementationHs mempty m))-  ---  putStrLn "Generating Template.hs"-  for_ tcms $ \m -> gen-                      (tcmModule m <.> "Template" <.> "hs")-                      (prettyPrint (buildTemplateHs m))-  ---  putStrLn "Generating TH.hs"-  for_ tcms $ \m -> gen-                      (tcmModule m <.> "TH" <.> "hs")-                      (prettyPrint (buildTHHs m))--  ---  -- TODO: Template.hs-boot need to be generated as well-  putStrLn "Generating hs-boot file"-  for_ hsbootlst $ \m -> gen-                           (m <.> "Interface" <.> "hs-boot")-                           (prettyPrint (buildInterfaceHSBOOT m))-  ---  putStrLn "Generating Module summary file"-  for_ mods $ \m -> gen-                      (cmModule m <.> "hs")-                      (prettyPrint (buildModuleHs m))-  ---  putStrLn "Generating Top-level Module"-  gen (topLevelMod <.> "hs") (prettyPrint (buildTopLevelHs topLevelMod (mods,tcms) tih))-  ---  putStrLn "Copying generated files to target directory"-  touch (workingDir </> "LICENSE")-  copyFileWithMD5Check (workingDir </> cabalFileName)  (installDir </> cabalFileName)-  copyFileWithMD5Check (workingDir </> jsonFileName)  (installDir </> jsonFileName)-  copyFileWithMD5Check (workingDir </> "LICENSE") (installDir </> "LICENSE")--  copyCppFiles workingDir (csrcDir installDir) (unCabalName pkgname) pkgconfig-  for_ mods (copyModule workingDir (srcDir installDir))-  for_ tcms (copyTemplateModule workingDir (srcDir installDir))-  moduleFileCopy workingDir (srcDir installDir) $ topLevelMod <.> "hs"--  putStrLn "----------------------------------------------------"-  putStrLn "-- Code generation has been completed. Enjoy!     --"-  putStrLn "----------------------------------------------------"----- | some dirty hack. later, we will do it with more proper approcah.--touch :: FilePath -> IO ()-touch fp = void (readProcess "touch" [fp] "")---copyFileWithMD5Check :: FilePath -> FilePath -> IO ()-copyFileWithMD5Check src tgt = do-  b <- doesFileExist tgt-  if b-    then do-      srcmd5 <- md5 <$> L.readFile src-      tgtmd5 <- md5 <$> L.readFile tgt-      if srcmd5 == tgtmd5 then return () else copyFile src tgt-    else copyFile src tgt---copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO ()-copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs acincs acsrcs) = do-  let thfile = cprefix <> "Type.h"-      tlhfile = tihHeaderFileName tih <.> "h"-      tlcppfile = tihHeaderFileName tih <.> "cpp"-  copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile)-  doesFileExist (wdir </> tlhfile)-    >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))-  doesFileExist (wdir </> tlcppfile)-    >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))-  for_ cihs $ \header-> do-    let hfile = unHdrName (cihSelfHeader header)-        cppfile = cihSelfCpp header-    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile)-    copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)--  for_ tcihs $ \header-> do-    let hfile = unHdrName (tcihSelfHeader header)-    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile)--  for_ acincs $ \(AddCInc header _) ->-    copyFileWithMD5Check (wdir </> header) (ddir </> header)--  for_ acsrcs $ \(AddCSrc csrc _) ->-    copyFileWithMD5Check (wdir </> csrc) (ddir </> csrc)---moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO ()-moduleFileCopy wdir ddir fname = do-  let (fnamebody,fnameext) = splitExtension fname-      (mdir,mfile) = moduleDirFile fnamebody-      origfpath = wdir </> fname-      (mfile',_mext') = splitExtension mfile-      newfpath = ddir </> mdir </> mfile' <> fnameext-  b <- doesFileExist origfpath-  when b $ do-    createDirectoryIfMissing True (ddir </> mdir)-    copyFileWithMD5Check origfpath newfpath---copyModule :: FilePath -> FilePath -> ClassModule -> IO ()-copyModule wdir ddir m = do-  let modbase = cmModule m-  moduleFileCopy wdir ddir $ modbase <> ".hs"-  moduleFileCopy wdir ddir $ modbase <> ".RawType.hs"-  moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc"-  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs"-  moduleFileCopy wdir ddir $ modbase <> ".Cast.hs"-  moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs"-  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot"---copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO ()-copyTemplateModule wdir ddir m = do-  let modbase = tcmModule m-  moduleFileCopy wdir ddir $ modbase <> ".Template.hs"-  moduleFileCopy wdir ddir $ modbase <> ".TH.hs"

@@ -1,291 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Code.Cabal--- Copyright   : (c) 2011-2019 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Code.Cabal where--import Data.Aeson.Encode.Pretty    (encodePretty)-import qualified Data.ByteString.Lazy as BL-import Data.List                   (intercalate, nub)-import Data.Monoid                 ((<>))-import Data.Text                   (Text)-import Data.Text.Template          (substitute)-import qualified Data.Text as T    (intercalate,pack,replicate,unlines)-import qualified Data.Text.Lazy as TL (toStrict)-import qualified Data.Text.IO as TIO (writeFile)-import System.FilePath             ((<.>),(</>))----import FFICXX.Generate.Type.Cabal  ( AddCInc(..)-                                   , AddCSrc(..)-                                   , BuildType(..)-                                   , CabalName(..)-                                   , Cabal(..)-                                   , GeneratedCabalInfo(..)-                                   )-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface-import FFICXX.Generate.Util---cabalIndentation :: Text-cabalIndentation = T.replicate 23 " "---unlinesWithIndent = T.unlines . map (cabalIndentation <>)---- for source distribution-genCsrcFiles :: (TopLevelImportHeader,[ClassModule])-             -> [AddCInc]-             -> [AddCSrc]-             -> [String]-genCsrcFiles (tih,cmods) acincs acsrcs =-  let -- indent = cabalIndentation-      selfheaders' = do-        x <- cmods-        y <- cmCIH x-        return (cihSelfHeader y)-      selfheaders = nub selfheaders'-      selfcpp' = do-        x <- cmods-        y <- cmCIH x-        return (cihSelfCpp y)-      selfcpp = nub selfcpp'-      tlh = tihHeaderFileName tih <.> "h"-      tlcpp = tihHeaderFileName tih <.> "cpp"-      includeFileStrsWithCsrc = map (\x->"csrc"</> x) $-                                 (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders))-                                 ++ map (\(AddCInc hdr _) -> hdr) acincs-      cppFilesWithCsrc = map (\x->"csrc"</>x)  $-                           (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)-                           ++ map (\(AddCSrc src _) -> src) acsrcs---  in includeFileStrsWithCsrc <> cppFilesWithCsrc---- for library-genIncludeFiles :: String        -- ^ package name-                -> ([ClassImportHeader],[TemplateClassImportHeader])-                -> [AddCInc]-                -> [String]-genIncludeFiles pkgname (cih,tcih) acincs =-  let -- indent = cabalIndentation-      selfheaders = map cihSelfHeader cih <> map tcihSelfHeader tcih-      includeFileStrs = map unHdrName (selfheaders ++ map (\(AddCInc hdr _) -> HdrName hdr) acincs)-  in (pkgname<>"Type.h") : includeFileStrs-----     unlines ((indent<>----- for library-genCppFiles :: (TopLevelImportHeader,[ClassModule])-            -> [AddCSrc]-            -> [String]-genCppFiles (tih,cmods) acsrcs =-  let -- indent = cabalIndentation-      selfcpp' = do-        x <- cmods-        y <- cmCIH x-        return (cihSelfCpp y)-      selfcpp = nub selfcpp'-      tlcpp = tihHeaderFileName tih <.> "cpp"-      cppFileStrs = map (\x -> "csrc" </> x)  $-                      (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)-                      ++ map (\(AddCSrc src _) -> src) acsrcs-  in cppFileStrs------ | generate exposed module list in cabal file-genExposedModules :: String -> ([ClassModule],[TemplateClassModule]) -> [String]-genExposedModules summarymod (cmods,tmods) =-    let -- indentspace = cabalIndentation-        -- summarystrs = summarymod-        cmodstrs = map cmModule cmods-        rawType = map ((\x -> x <> ".RawType").cmModule) cmods-        ffi = map ((\x -> x <> ".FFI").cmModule) cmods-        interface= map ((\x-> x <> ".Interface").cmModule) cmods-        cast = map ((\x-> x <> ".Cast").cmModule) cmods-        implementation = map ((\x-> x <> ".Implementation").cmModule) cmods-        template = map ((\x-> x <> ".Template").tcmModule) tmods-        th = map ((\x-> x <> ".TH").tcmModule) tmods-    in  -- unlines-        [summarymod]<>cmodstrs<>rawType<>ffi<>interface<>cast<>implementation<>template<>th---- | generate other modules in cabal file-genOtherModules :: [ClassModule] -> [String]-genOtherModules _cmods = [""]---- | generate additional package dependencies.-genPkgDeps :: [CabalName] -> [String]-genPkgDeps cs =    [ "base > 4 && < 5"-                   , "fficxx >= 0.5"-                   , "fficxx-runtime >= 0.5"-                   , "template-haskell"-                   ]-                ++ map unCabalName cs------ |-cabalTemplate :: Text-cabalTemplate =-  "Name:                $pkgname\n\-  \Version:     $version\n\-  \Synopsis:    $synopsis\n\-  \Description:         $description\n\-  \Homepage:       $homepage\n\-  \$licenseField\n\-  \$licenseFileField\n\-  \Author:              $author\n\-  \Maintainer:  $maintainer\n\-  \Category:       $category\n\-  \Tested-with:    GHC >= 7.6\n\-  \$buildtype\n\-  \cabal-version:  >= 2\n\-  \Extra-source-files:\n\-  \$extraFiles\n\-  \$csrcFiles\n\-  \\n\-  \$sourcerepository\n\-  \\n\-  \Library\n\-  \  default-language: Haskell2010\n\-  \  hs-source-dirs: src\n\-  \  ghc-options:  -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\-  \  ghc-prof-options: -caf-all -auto-all\n\-  \  cxx-options: $cxxOptions\n\-  \  Build-Depends: $pkgdeps\n\-  \  Exposed-Modules:\n\-  \$exposedModules\n\-  \  Other-Modules:\n\-  \$otherModules\n\-  \  extra-lib-dirs: $extralibdirs\n\-  \  extra-libraries:    $extraLibraries\n\-  \  Include-dirs:       csrc $extraincludedirs\n\-  \  pkgconfig-depends: $pkgconfigDepends\n\-  \  Install-includes:\n\-  \$includeFiles\n\-  \  C-sources:\n\-  \$cppFiles\n"------ TODO: remove all T.pack after we switch over to Text-genCabalInfo-  :: Cabal-  -> String-  -> PackageConfig-  -> [String] -- ^ extra libs-  -> GeneratedCabalInfo-genCabalInfo cabal summarymodule pkgconfig extralibs =-  let tih = pcfg_topLevelImportHeader pkgconfig-      classmodules = pcfg_classModules pkgconfig-      cih = pcfg_classImportHeaders pkgconfig-      tmods = pcfg_templateClassModules pkgconfig-      tcih = pcfg_templateClassImportHeaders pkgconfig-      acincs = pcfg_additional_c_incs pkgconfig-      acsrcs = pcfg_additional_c_srcs pkgconfig-      extrafiles = cabal_extrafiles cabal-  in GeneratedCabalInfo {-       gci_pkgname          = T.pack (unCabalName (cabal_pkgname cabal))-     , gci_version          = T.pack (cabal_version cabal)-     , gci_synopsis         = ""-     , gci_description      = ""-     , gci_homepage         = ""-     , gci_license          = maybe "" T.pack (cabal_license cabal)-     , gci_licenseFile      = maybe "" T.pack (cabal_licensefile cabal)-     , gci_author           = ""-     , gci_maintainer       = ""-     , gci_category         = ""-     , gci_buildtype        = case cabal_buildType cabal of-                                Simple ->-                                  "Build-Type: Simple"-                                Custom deps ->-                                     "Build-Type: Custom\ncustom-setup\n  setup-depends: "-                                  <> T.pack (intercalate ", " (map unCabalName deps))-                                  <> "\n"-     , gci_extraFiles       = map T.pack extrafiles-     , gci_csrcFiles        = map T.pack $ genCsrcFiles (tih,classmodules) acincs acsrcs-     , gci_sourcerepository = ""-     , gci_cxxOptions       = ["-std=c++14"]-     , gci_pkgdeps          = map T.pack $ genPkgDeps (cabal_additional_pkgdeps cabal)-     , gci_exposedModules   = map T.pack $ genExposedModules summarymodule (classmodules,tmods)-     , gci_otherModules     = map T.pack $ genOtherModules classmodules-     , gci_extraLibDirs     = map T.pack $ cabal_extralibdirs cabal-     , gci_extraLibraries   = map T.pack extralibs-     , gci_extraIncludeDirs = map T.pack $ cabal_extraincludedirs cabal-     , gci_pkgconfigDepends = map T.pack $ cabal_pkg_config_depends cabal-     , gci_includeFiles     = map T.pack $ genIncludeFiles (unCabalName (cabal_pkgname cabal)) (cih,tcih) acincs-     , gci_cppFiles         = map T.pack $ genCppFiles (tih,classmodules) acsrcs-     }---genCabalFile :: GeneratedCabalInfo -> Text-genCabalFile GeneratedCabalInfo {..} =-  TL.toStrict $-    substitute cabalTemplate $-      contextT [ ("licenseField"    , "license: " <> gci_license)-               , ("licenseFileField", "license-file: " <> gci_licenseFile)-               , ("pkgname"         , gci_pkgname)-               , ("version"         , gci_version)-               , ("buildtype"       , gci_buildtype)-               , ("synopsis"        , gci_synopsis)-               , ("description"     , gci_description)-               , ("homepage"        , gci_homepage)-               , ("author"          , gci_author)-               , ("maintainer"      , gci_maintainer)-               , ("category"        , gci_category)-               , ("sourcerepository", gci_sourcerepository)-               , ("cxxOptions"       , T.intercalate " " gci_cxxOptions)-               , ("pkgdeps"         , T.intercalate ", " gci_pkgdeps)-               , ("extraFiles"      , unlinesWithIndent gci_extraFiles)-               , ("csrcFiles"       , unlinesWithIndent gci_csrcFiles)-               , ("includeFiles"    , unlinesWithIndent gci_includeFiles)-               , ("cppFiles"        , unlinesWithIndent gci_cppFiles)-               , ("exposedModules"  , unlinesWithIndent gci_exposedModules)-               , ("otherModules"    , unlinesWithIndent gci_otherModules)-               , ("extralibdirs"    , T.intercalate ", " gci_extraLibDirs)-               , ("extraincludedirs", T.intercalate ", " gci_extraIncludeDirs)-               , ("extraLibraries"  , T.intercalate ", " gci_extraLibraries)-               , ("cabalIndentation", cabalIndentation)-               , ("pkgconfigDepends", T.intercalate ", " gci_pkgconfigDepends)-               ]----- |-buildCabalFile-  :: Cabal-  -> String-  -> PackageConfig-  -> [String]      -- ^ Extra libs-  -> FilePath      -- ^ Cabal file path-  -> IO ()-buildCabalFile cabal summarymodule pkgconfig extralibs cabalfile = do-  let-      cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs-      txt = genCabalFile cinfo-  TIO.writeFile cabalfile txt----- |-buildJSONFile-  :: Cabal-  -> String-  -> PackageConfig-  -> [String]      -- ^ Extra libs-  -> FilePath      -- ^ JSON file path-  -> IO ()-buildJSONFile cabal summarymodule pkgconfig extralibs jsonfile = do-  let cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs-  BL.writeFile jsonfile (encodePretty cinfo)

@@ -1,490 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Code.Cpp--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Code.Cpp where--import Data.Char-import Data.List                             (intercalate)-import Data.Monoid                           ((<>))----import FFICXX.Generate.Code.Primitive        (accessorCFunSig-                                             ,argsToCallString-                                             ,argsToString-                                             ,argsToStringNoSelf-                                             ,castCpp2C-                                             ,castC2Cpp-                                             ,CFunSig(..)-                                             ,genericFuncArgs-                                             ,genericFuncRet-                                             ,rettypeToString-                                             ,tmplMemFuncArgToString-                                             ,tmplMemFuncRetTypeToString-                                             ,tmplAllArgsToCallString-                                             ,tmplAllArgsToString-                                             ,tmplRetTypeToString)-import FFICXX.Generate.Name                  (aliasedFuncName-                                             ,cppFuncName-                                             ,ffiClassName-                                             ,ffiTmplFuncName-                                             ,hsTemplateMemberFunctionName)-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface-import FFICXX.Generate.Util---------- Class Declaration and Definition-------------- Declaration----------- "Class Type Declaration" Instances--genCppHeaderMacroType :: Class -> String-genCppHeaderMacroType c = let tmpl = "// Opaque type definition for $classname \n\-                                    \typedef struct ${classname}_tag ${classname}_t; \n\-                                    \typedef ${classname}_t * ${classname}_p; \n\-                                    \typedef ${classname}_t const* const_${classname}_p; \n"-                      in subst tmpl (context [ ("classname", ffiClassName c) ])------- "Class Declaration Virtual" Declaration--genCppHeaderMacroVirtual :: Class -> String-genCppHeaderMacroVirtual aclass =-  let tmpl = "#undef ${classname}_DECL_VIRT \n#define ${classname}_DECL_VIRT(Type) \\\n${funcdecl}"-      funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass-  in subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) )-                         , ("funcdecl" , funcDeclStr                     ) ])------- "Class Declaration Non-Virtual" Declaration--genCppHeaderMacroNonVirtual :: Class -> String-genCppHeaderMacroNonVirtual c =-  let tmpl = "#undef ${classname}_DECL_NONVIRT \n#define ${classname}_DECL_NONVIRT(Type) \\\n$funcdecl"-      declBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c))-                                        , ("funcdecl" , funcDeclStr               ) ])-      funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc)-                                     . class_funcs $ c-  in  declBodyStr------- "Class Declaration Accessor" Declaration--genCppHeaderMacroAccessor :: Class -> String-genCppHeaderMacroAccessor c =-  let tmpl = "#undef ${classname}_DECL_ACCESSOR\n#define ${classname}_DECL_ACCESSOR(Type)\\\n$funcdecl"-      declBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c))-                                        , ("funcdecl" , funcDeclStr               ) ])-      funcDeclStr = accessorsToDecls (class_vars c)-  in  declBodyStr------- "Class Declaration Virtual/NonVirtual/Accessor" Instances--genCppHeaderInstVirtual :: (Class,Class) -> String-genCppHeaderInstVirtual (p,c) =-  let strc = map toUpper (ffiClassName p)-  in  strc<>"_DECL_VIRT(" <> ffiClassName c <> ");\n"--genCppHeaderInstNonVirtual :: Class -> String-genCppHeaderInstNonVirtual c =-  let strx = map toUpper (ffiClassName c)-  in  strx<>"_DECL_NONVIRT(" <> ffiClassName c <> ");\n"---genCppHeaderInstAccessor :: Class -> String-genCppHeaderInstAccessor c =-  let strx = map toUpper (ffiClassName c)-  in  strx<>"_DECL_ACCESSOR(" <> ffiClassName c <> ");\n"------------ Definition----------- "Class Definition Virtual" Declaration--genCppDefMacroVirtual :: Class -> String-genCppDefMacroVirtual aclass =-  let tmpl = "#undef ${classname}_DEF_VIRT\n#define ${classname}_DEF_VIRT(Type)\\\n$funcdef"-      defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) )-                                       , ("funcdef"  , funcDefStr                      ) ])-      funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass-  in  defBodyStr------- "Class Definition NonVirtual" Declaration--genCppDefMacroNonVirtual :: Class -> String-genCppDefMacroNonVirtual aclass =-  let tmpl = "#undef ${classname}_DEF_NONVIRT\n#define ${classname}_DEF_NONVIRT(Type)\\\n$funcdef"-      defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName aclass) )-                                       , ("funcdef"  , funcDefStr                      ) ])-      funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc)-                                        . class_funcs $ aclass-  in  defBodyStr------- Define Macro to provide Accessor C-C++ shim code for a class--genCppDefMacroAccessor :: Class -> String-genCppDefMacroAccessor c =-  let tmpl = "#undef ${classname}_DEF_ACCESSOR\n#define ${classname}_DEF_ACCESSOR(Type)\\\n$funcdef"-      defBodyStr = subst tmpl (context [ ("classname", map toUpper (ffiClassName c))-                                       , ("funcdef"  , funcDefStr                  ) ])-      funcDefStr = accessorsToDefs (class_vars c)-  in  defBodyStr------ Define Macro to provide TemplateMemberFunction C-C++ shim code for a class--genCppDefMacroTemplateMemberFunction :: Class -> TemplateMemberFunction -> String-genCppDefMacroTemplateMemberFunction c f = subst tmpl ctxt-  where-    tmpl = "#define ${macroname}(Type) \\\n\-           \  extern \"C\" { \\\n\-           \    $decl; \\\n\-           \  } \\\n\-           \  inline $defn \\\n\-           \  auto a_${macroname}_##Type = ${macroname}_##Type  ;\n"-    ctxt = context-             [ ("macroname", hsTemplateMemberFunctionName c f)-             , ("decl"     , tmplMemberFunToDecl c f)-             , ("defn"     , tmplMemberFunToDef c f)-             ]------- Invoke Macro to define Virtual/NonVirtual method for a class--genCppDefInstVirtual :: (Class,Class) -> String-genCppDefInstVirtual (p,c) =-  let strc = map toUpper (ffiClassName p)-  in  strc<>"_DEF_VIRT(" <> ffiClassName c <> ")\n"--genCppDefInstNonVirtual :: Class -> String-genCppDefInstNonVirtual c =-  subst "${capitalclassname}_DEF_NONVIRT(${classname})"-    (context [ ("capitalclassname", toUppers (ffiClassName c))-             , ("classname"       , ffiClassName c           ) ])--genCppDefInstAccessor :: Class -> String-genCppDefInstAccessor c =-  subst "${capitalclassname}_DEF_ACCESSOR(${classname})"-    (context [ ("capitalclassname", toUppers (ffiClassName c))-             , ("classname"       , ffiClassName c           ) ])---------------------genAllCppHeaderInclude :: ClassImportHeader -> String-genAllCppHeaderInclude header =-    intercalateWith connRet (\x->"#include \""<>x<>"\"") $-      map unHdrName (cihIncludedHPkgHeadersInCPP header-                     <> cihIncludedCPkgHeaders header)-------------------------------------- TOP LEVEL FUNCTIONS ------------------------------genTopLevelFuncCppHeader :: TopLevelFunction -> String-genTopLevelFuncCppHeader TopLevelFunction {..} =-  subst "$returntype $funcname ( $args );"-    (context [ ("returntype", rettypeToString toplevelfunc_ret                )-             , ("funcname"  , "TopLevel_"-                              <> maybe toplevelfunc_name id toplevelfunc_alias)-             , ("args"      , argsToStringNoSelf toplevelfunc_args            ) ])-genTopLevelFuncCppHeader TopLevelVariable {..} =-  subst "$returntype $funcname ( );"-    (context [ ("returntype", rettypeToString toplevelvar_ret                )-             , ("funcname"  , "TopLevel_"-                               <> maybe toplevelvar_name id toplevelvar_alias) ])--genTopLevelFuncCppDefinition :: TopLevelFunction -> String-genTopLevelFuncCppDefinition TopLevelFunction {..} =-  let tmpl = "$returntype $funcname ( $args ) { \n  $funcbody\n}"-      callstr = toplevelfunc_name <> "("-                <> argsToCallString toplevelfunc_args-                <> ")"-      funcDefStr = returnCpp False (toplevelfunc_ret) callstr-  in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret                )-                         , ("funcname"  , "TopLevel_"-                                          <> maybe toplevelfunc_name id toplevelfunc_alias)-                         , ("args"      , argsToStringNoSelf toplevelfunc_args            )-                         , ("funcbody"  , funcDefStr                                      ) ])-genTopLevelFuncCppDefinition TopLevelVariable {..} =-  let tmpl = "$returntype $funcname ( ) { \n  $funcbody\n}"-      callstr = toplevelvar_name-      funcDefStr = returnCpp False (toplevelvar_ret) callstr-  in subst tmpl (context [ ("returntype", rettypeToString toplevelvar_ret               )-                         , ("funcname"  , "TopLevel_"-                                          <> maybe toplevelvar_name id toplevelvar_alias)-                         , ("funcbody"  , funcDefStr                                    ) ])---genTmplFunCpp :: Bool -- ^ is for simple type?-              -> TemplateClass-              -> TemplateFunction-              -> String-genTmplFunCpp b t@TmplCls {..} f = subst tmpl ctxt- where-  tmpl = "#define ${tname}_${fname}${suffix}(Type) \\\n\-         \  extern \"C\" { \\\n\-         \    $decl; \\\n\-         \  } \\\n\-         \  inline $defn \\\n\-         \  auto a_${tname}_${fname}_ ## Type = ${tname}_${fname}_ ## Type  ;\n"-  ctxt = context $-           (("suffix",if b then "_s" else ""):) $-             [ ("tname"  , tclass_name )-             , ("fname"  , ffiTmplFuncName f)-             , ("decl"   , tmplFunToDecl b t f )-             , ("defn"   , tmplFunToDef b t f ) ]--genTmplClassCpp :: Bool -- ^ is for simple type-                -> TemplateClass-                -> [TemplateFunction]-                -> String-genTmplClassCpp b TmplCls {..} fs = subst tmpl ctxt- where-  tmpl = "#define ${tname}_instance${suffix}(Type) \\\n\-         \$macro\n"-  suffix = if b then "_s" else ""-  ctxt = context [ ("tname"  , tclass_name )-                 , ("suffix" , suffix      )-                 , ("macro"  , macro       ) ]-  tname = tclass_name-  macro1 f@TFun {..}    = "  " <> tname<> "_" <> ffiTmplFuncName f <> suffix <> "(Type) \\"--  macro1 f@TFunNew {..} = "  " <> tname<> "_" <> ffiTmplFuncName f <> "(Type) \\"-  macro1 TFunDelete     = "  " <> tname<> "_delete(Type) \\"-  macro = intercalateWith connRet macro1 fs--returnCpp :: Bool  -- ^ for simple type-          -> Types-          -> String -- ^ call string-          -> String-returnCpp b ret callstr =-  case ret of-    Void                    -> callstr <> ";"-    SelfType                -> "return to_nonconst<Type ## _t, Type>((Type *)"-                                <> callstr <> ") ;"-    CT (CRef _) _           -> "return (&("<>callstr<>"));"-    CT _ _                  -> "return "<>callstr<>";"-    CPT (CPTClass c') _     -> "return to_nonconst<"<>str<>"_t,"<>str-                               <>">(("<>str<>"*)"<>callstr<>");"-                               where str = ffiClassName c'-    CPT (CPTClassRef c') _  -> "return to_nonconst<"<>str<>"_t,"<>str-                               <>">(&("<>callstr<>"));"-                               where str = ffiClassName c'-    CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str-                               <>">(new "<>str<>"("<>callstr<>"));"-                               where str = ffiClassName c'-    CPT (CPTClassMove c') _ -> -- TODO: check whether this is working or not.-                               "return std::move(to_nonconst<"<>str<>"_t,"<>str-                               <>">(&("<>callstr<>")));"-                               where str = ffiClassName c'-    TemplateApp (TemplateAppInfo _ _ cpptype) ->-         cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); "-      <> "return (static_cast<void*>(r));"-    TemplateAppRef (TemplateAppInfo _ _ cpptype) ->-         cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); "-      <> "return (static_cast<void*>(r));"-    TemplateAppMove (TemplateAppInfo _ _ cpptype) ->-         cpptype <> "* r = new " <> cpptype <> "(" <> callstr <> "); "-      <> "return std::move(static_cast<void*>(r));"-    TemplateType _          -> error "returnCpp: TemplateType"-    TemplateParam _         ->-      if b then "return (" <> callstr <> ");"-           else "return to_nonconst<Type ## _t, Type>((Type *)&("-                <> callstr <> ")) ;"-    TemplateParamPointer _  ->-      if b then "return (" <> callstr <> ");"-           else "return to_nonconst<Type ## _t, Type>("-                <> callstr <> ") ;"------ Function Declaration and Definition--funcToDecl :: Class -> Function -> String-funcToDecl c func-  | isNewFunc func || isStaticFunc func =-    let tmpl = "$returntype Type ## _$funcname ( $args )"-    in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func))-                           , ("funcname",  aliasedFuncName c func)-                           , ("args", argsToStringNoSelf (genericFuncArgs func))-                           ])-  | otherwise =-    let tmpl = "$returntype Type ## _$funcname ( $args )"-    in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func))-                           , ("funcname", aliasedFuncName c func)-                           , ("args", argsToString (genericFuncArgs func))-                           ])----funcsToDecls :: Class -> [Function] -> String-funcsToDecls c = intercalateWith connSemicolonBSlash (funcToDecl c)---funcToDef :: Class -> Function -> String-funcToDef c func-  | isNewFunc func =-    let declstr = funcToDecl c func-        callstr = "(" <> argsToCallString (genericFuncArgs func) <> ")"-        returnstr = "Type * newp = new Type " <> callstr <> "; \\\nreturn to_nonconst<Type ## _t, Type >(newp);"-    in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"]-  | isDeleteFunc func =-    let declstr = funcToDecl c func-        returnstr = "delete (to_nonconst<Type,Type ## _t>(p)) ; "-    in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"]-  | isStaticFunc func =-    let declstr = funcToDecl c func-        callstr = cppFuncName c func <> "("-                  <> argsToCallString (genericFuncArgs func)-                  <> ")"-        returnstr = returnCpp False (genericFuncRet func) callstr-    in intercalateWith connBSlash id [declstr, "{", returnstr, "}"]-  | otherwise =-    let declstr = funcToDecl c func-        callstr = "TYPECASTMETHOD(Type,"<> aliasedFuncName c func <> "," <> class_name c <> ")(p)->"-                  <> cppFuncName c func <> "("-                  <> argsToCallString (genericFuncArgs func)-                  <> ")"-        returnstr = returnCpp False (genericFuncRet func) callstr-    in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"]----funcsToDefs :: Class -> [Function] -> String-funcsToDefs c = intercalateWith connBSlash (funcToDef c)---tmplFunToDecl :: Bool -> TemplateClass -> TemplateFunction -> String-tmplFunToDecl b t@TmplCls {..} f@TFun {..} =-  subst "$ret ${tname}_${fname}_ ## Type ( $args )"-    (context [ ("tname", tclass_name)-             , ("fname", ffiTmplFuncName f)-             , ("args" , tmplAllArgsToString b Self t tfun_args)-             , ("ret"  , tmplRetTypeToString b tfun_ret) ])-tmplFunToDecl b t@TmplCls {..} f@TFunNew {..} =-  subst "$ret ${tname}_${fname}_ ## Type ( $args )"-    (context [ ("tname", tclass_name)-             , ("fname", ffiTmplFuncName f)-             , ("args" , tmplAllArgsToString b NoSelf t tfun_new_args)-             , ("ret"  , tmplRetTypeToString b (TemplateType t)) ])-tmplFunToDecl b t@TmplCls {..} TFunDelete =-  subst "$ret ${tname}_delete_ ## Type ( $args )"-    (context [ ("tname", tclass_name                     )-             , ("args" , tmplAllArgsToString b Self t [] )-             , ("ret"  , "void" ) ])----tmplFunToDef :: Bool -- ^ for simple type-             -> TemplateClass-             -> TemplateFunction-             -> String-tmplFunToDef b t@TmplCls {..} f = intercalateWith connBSlash id [declstr, "  {", "    "<>returnstr, "  }"]- where-  declstr = tmplFunToDecl b t f-  callstr =-    case f of-      TFun {..}    -> "(static_cast<" <> tclass_oname <> "<Type>*>(p))->"-                      <> tfun_oname <> "("-                      <> tmplAllArgsToCallString b tfun_args-                      <> ")"-      TFunNew {..} -> "new " <> tclass_oname <> "<Type>("-                      <> tmplAllArgsToCallString b tfun_new_args-                      <> ")"-      TFunDelete   -> "delete (static_cast<" <> tclass_oname <> "<Type>*>(p))"-  returnstr =-    case f of-      TFunNew {..} -> "return static_cast<void*>("<>callstr<>");"-      TFunDelete   -> callstr <> ";"-      TFun {..} -> returnCpp b (tfun_ret) callstr----- Accessor Declaration and Definition--accessorToDecl :: Variable -> Accessor -> String-accessorToDecl v a =-  let tmpl = "$returntype Type ## _$funcname ( $args )"-      csig = accessorCFunSig (var_type v) a-  in subst tmpl (context [ ("returntype", rettypeToString (cRetType csig))-                         , ("funcname"  , var_name v <> "_" <> case a of Getter -> "get"; Setter -> "set")-                         , ("args"      , argsToString (cArgTypes csig))-                         ])--accessorsToDecls :: [Variable] -> String-accessorsToDecls vs =-  let dcls = concatMap (\v -> [accessorToDecl v Getter,accessorToDecl v Setter]) vs-  in intercalate "; \\\n" dcls---accessorToDef :: Variable -> Accessor -> String-accessorToDef v a =-  let declstr = accessorToDecl v a-      varexp = "to_nonconst<Type,Type ## _t>(p)->" <> var_name v-      body Getter = "return (" <> castCpp2C (var_type v) varexp <> ");"-      body Setter =    varexp-                    <> " = "-                    <> castC2Cpp (var_type v) "x"  -- TODO: somehow clean up this hard-coded "x".-                    <> ";"-  in  intercalate "\\\n" [declstr, "{", body a, "}"]---accessorsToDefs :: [Variable] -> String-accessorsToDefs vs =-  let defs = concatMap (\v -> [accessorToDef v Getter,accessorToDef v Setter]) vs-  in intercalate "; \\\n" defs------ Template Member Function Declaration and Definition---- TODO: Handle simple type-tmplMemberFunToDecl :: Class -> TemplateMemberFunction -> String-tmplMemberFunToDecl c f =-  subst "$ret ${macroname}_##Type ( $args )"-    (context [ ("macroname", hsTemplateMemberFunctionName c f)-             , ("args"     , intercalateWith conncomma (tmplMemFuncArgToString c) ((SelfType,"p"):tmf_args f))-             , ("ret"      , tmplMemFuncRetTypeToString c (tmf_ret f))-             ])----- TODO: Handle simple type-tmplMemberFunToDef :: Class -> TemplateMemberFunction -> String-tmplMemberFunToDef c f =-    intercalateWith connBSlash id [ declstr-                                  , "  {"-                                  , "    " <> returnstr-                                  , "  }"-                                  ]-  where-    declstr = tmplMemberFunToDecl c f-    callstr =    "(to_nonconst<" <> ffiClassName c  <> "," <> ffiClassName c <> "_t" <> ">(p))"-              <> "->"-              <> tmf_name f-              <> "<Type>"-              <> "(" <> tmplAllArgsToCallString False (tmf_args f) <> ")"-    returnstr = returnCpp False (tmf_ret f) callstr

@@ -1,37 +0,0 @@-module FFICXX.Generate.Code.HsCast where--import Language.Haskell.Exts.Build             (app)-import Language.Haskell.Exts.Syntax            (Decl(..),InstDecl(..))----import FFICXX.Generate.Name                    (hsClassName,typeclassName)-import FFICXX.Generate.Type.Class              (Class(..),isAbstractClass)-import FFICXX.Generate.Util.HaskellSrcExts     (classA-                                               ,cxEmpty,cxTuple,insDecl-                                               ,mkBind1,mkInstance,mkPVar,mkTVar,mkVar-                                               ,tyapp,tycon,tyPtr-                                               ,unqual)--------castBody :: [InstDecl ()]-castBody =-  [ insDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "castPtr") (app (mkVar "get_fptr") (mkVar "x")))) Nothing)-  , insDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "cast_fptr_to_obj") (app (mkVar "castPtr") (mkVar "x")))) Nothing)-  ]--genHsFrontInstCastable :: Class -> Maybe (Decl ())-genHsFrontInstCastable c-  | (not.isAbstractClass) c =-    let iname = typeclassName c-        (_,rname) = hsClassName c-        a = mkTVar "a"-        ctxt = cxTuple [ classA (unqual iname) [a], classA (unqual "FPtr") [a] ]-    in Just (mkInstance ctxt "Castable" [a,tyapp tyPtr (tycon rname)] castBody)-  | otherwise = Nothing--genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())-genHsFrontInstCastableSelf c-  | (not.isAbstractClass) c =-    let (cname,rname) = hsClassName c-    in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)-  | otherwise = Nothing-

@@ -1,104 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Code.HsFFI--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Code.HsFFI where--import Data.Maybe                              (fromMaybe,mapMaybe)-import Data.Monoid                             ((<>))-import Language.Haskell.Exts.Syntax            (Decl(..),ImportDecl(..))-import System.FilePath                         ((<.>))----import FFICXX.Generate.Code.Primitive          (CFunSig(..)-                                               ,accessorCFunSig-                                               ,genericFuncArgs-                                               ,genericFuncRet-                                               ,hsFFIFuncTyp)-import FFICXX.Generate.Dependency              (class_allparents-                                               ,getClassModuleBase-                                               ,getTClassModuleBase)-import FFICXX.Generate.Name                    (aliasedFuncName-                                               ,ffiClassName-                                               ,hscAccessorName-                                               ,hscFuncName)-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Type.PackageInterface-import FFICXX.Generate.Util-import FFICXX.Generate.Util.HaskellSrcExts---genHsFFI :: ClassImportHeader -> [Decl ()]-genHsFFI header =-  let c = cihClass header-      -- TODO: This C header information should not be necessary according to up-to-date-      --       version of Haskell FFI.-      h = cihSelfHeader header-      -- NOTE: We need to generate FFI both for member functions at the current class level-      --       and parent level. For example, consider a class A with method foo, which a-      --       subclass of B with method bar. Then, A::foo (c_a_foo) and A::bar (c_a_bar)-      --       are made into a FFI function.-      allfns =    concatMap (virtualFuncs . class_funcs)-                            (class_allparents c)-               <> (class_funcs c)--  in    mapMaybe (hsFFIClassFunc h c) allfns-     <> concatMap-          (\v -> [hsFFIAccessor c v Getter, hsFFIAccessor c v Setter])-          (class_vars c)--hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ())-hsFFIClassFunc headerfilename c f =-  if isAbstractClass c-  then Nothing-  else let hfile = unHdrName headerfilename-           -- TODO: Make this a separate function-           cname = ffiClassName c <> "_" <> aliasedFuncName c f-           csig = CFunSig (genericFuncArgs f) (genericFuncRet f)-           typ = if (isNewFunc f || isStaticFunc f)-                 then hsFFIFuncTyp (Just (NoSelf,c)) csig-                 else hsFFIFuncTyp (Just (Self,c)  ) csig-       in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ)---hsFFIAccessor ::Class -> Variable -> Accessor -> Decl ()-hsFFIAccessor c v a =-  let -- TODO: make this a separate function-      cname = ffiClassName c <> "_" <> var_name v <> "_" <> (case a of Getter -> "get"; Setter -> "set")-      typ = hsFFIFuncTyp (Just (Self,c)) (accessorCFunSig (var_type v) a)-  in mkForImpCcall cname (hscAccessorName c v a) typ----- import for FFI--genImportInFFI :: ClassModule -> [ImportDecl ()]-genImportInFFI = map mkMod . cmImportedModulesForFFI-  where mkMod (Left t)  = mkImport (getTClassModuleBase t <.> "Template")-        mkMod (Right c) = mkImport (getClassModuleBase c <.> "RawType")---------------------------------- for top level function ---------------------------------genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl ()-genTopLevelFuncFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ-  where (fname,args,ret) =-          case tfn of-            TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret)-            TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret)-        hfilename = tihHeaderFileName header <.> "h"-        -- TODO: This must be exposed as a top-level function-        cfname = "c_" <> toLowers fname-        typ =hsFFIFuncTyp Nothing (CFunSig args ret)

@@ -1,334 +0,0 @@-{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE LambdaCase        #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards   #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Code.HsFrontEnd--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Code.HsFrontEnd where--import Control.Monad.Reader-import Data.Either                             (lefts,rights)-import Data.List-import Data.Monoid                             ((<>))-import Language.Haskell.Exts.Build             (app,letE,name,pApp)-import Language.Haskell.Exts.Syntax            (Decl(..),ExportSpec(..),ImportDecl(..))-import System.FilePath                         ((<.>))----import FFICXX.Generate.Code.Primitive          (CFunSig(..),HsFunSig(..)-                                               ,accessorSignature-                                               ,classConstraints-                                               ,convertCpp2HS-                                               ,extractArgRetTypes-                                               ,functionSignature-                                               ,hsFuncXformer-                                               )-import FFICXX.Generate.Name                    (accessorName-                                               ,aliasedFuncName-                                               ,hsClassName-                                               ,hscAccessorName-                                               ,hscFuncName-                                               ,hsFuncName-                                               ,hsFrontNameForTopLevelFunction-                                               ,typeclassName)-import FFICXX.Generate.Dependency              (class_allparents-                                               ,extractClassDepForTopLevelFunction-                                               ,getClassModuleBase,getTClassModuleBase-                                               ,argumentDependency,returnDependency-                                               )-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Annotate-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Util-import FFICXX.Generate.Util.HaskellSrcExts---genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ())-genHsFrontDecl c = do-  -- TODO: revive annotation-  -- for the time being, let's ignore annotation.-  -- amap <- ask-  -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap-  let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body-      sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f)-      body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c-  return cdecl-----------------------genHsFrontInst :: Class -> Class -> [Decl ()]-genHsFrontInst parent child-  | (not.isAbstractClass) child =-    let idecl = mkInstance cxEmpty (typeclassName parent) [convertCpp2HS (Just child) SelfType] body-        defn f = mkBind1 (hsFuncName child f) [] rhs Nothing-          where rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))-        body = map (insDecl . defn) . virtualFuncs . class_funcs $ parent-    in [idecl]-  | otherwise = []----------------------------genHsFrontInstNew :: Class         -- ^ only concrete class-                  -> Reader AnnotateMap [Decl ()]-genHsFrontInstNew c = do-  -- amap <- ask-  let fs = filter isNewFunc (class_funcs c)-  return . flip concatMap fs $ \f ->-    let-        -- for the time being, let's ignore annotation.-        -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap-        -- newfuncann = mkComment 0 cann-        rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))-    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing--genHsFrontInstNonVirtual :: Class -> [Decl ()]-genHsFrontInstNonVirtual c =-  flip concatMap nonvirtualFuncs $ \f ->-    let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))-    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing- where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c)---------genHsFrontInstStatic :: Class -> [Decl ()]-genHsFrontInstStatic c =-  flip concatMap (staticFuncs (class_funcs c)) $ \f ->-    let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))-    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing---------genHsFrontInstVariables :: Class -> [Decl ()]-genHsFrontInstVariables c =-  flip concatMap (class_vars c) $ \v ->-    let rhs accessor =-          app (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1"))-              (mkVar (hscAccessorName c v accessor))-    in    mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing-       <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing---------------------------------hsClassRawType :: Class -> [Decl ()]-hsClassRawType c =-  [ mkData    rawname [] [] Nothing-  , mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv-  , mkInstance cxEmpty "FPtr" [hightype]-      [ insType (tyapp (tycon "Raw") hightype) rawtype-      , insDecl (mkBind1 "get_fptr" [pApp (name highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)-      , insDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing)-      ]--  ]- where (highname,rawname) = hsClassName c-       hightype = tycon highname-       rawtype = tycon rawname-       mderiv = Just (mkDeriving [i_eq,i_ord,i_show])-         where i_eq   = irule Nothing Nothing (ihcon (unqual "Eq"))-               i_ord  = irule Nothing Nothing (ihcon (unqual "Ord"))-               i_show = irule Nothing Nothing (ihcon (unqual "Show"))------------------ upcast -----------------genHsFrontUpcastClass :: Class -> [Decl ()]-genHsFrontUpcastClass c = mkFun ("upcast"<>highname) typ [mkPVar "h"] rhs Nothing-  where (highname,rawname) = hsClassName c-        hightype = tycon highname-        rawtype = tycon rawname-        iname = typeclassName c-        a_bind = unkindedVar (name "a")-        a_tvar = mkTVar "a"-        typ = tyForall (Just [a_bind])-                (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))-                (tyfun a_tvar hightype)-        rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing-                   , pbind (mkPVarSig "fh2" (tyapp tyPtr rawtype))-                       (app (mkVar "castPtr") (mkVar "fh")) Nothing-                   ]-                   (mkVar "cast_fptr_to_obj" `app` mkVar "fh2")-------------------- downcast -------------------genHsFrontDowncastClass :: Class -> [Decl ()]-genHsFrontDowncastClass c = mkFun ("downcast"<>highname) typ [mkPVar "h"] rhs Nothing-  where (highname,_rawname) = hsClassName c-        hightype = tycon highname-        iname = typeclassName c-        a_bind = unkindedVar (name "a")-        a_tvar = mkTVar "a"-        typ = tyForall (Just [a_bind])-                (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))-                (tyfun hightype a_tvar)-        rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing-                   , pbind (mkPVar "fh2") (app (mkVar "castPtr") (mkVar "fh")) Nothing-                   ]-                   (mkVar "cast_fptr_to_obj" `app` mkVar "fh2")------------------------------ Top Level Function ------------------------------genTopLevelFuncDef :: TopLevelFunction -> [Decl ()]-genTopLevelFuncDef f@TopLevelFunction {..} =-    let fname = hsFrontNameForTopLevelFunction f-        HsFunSig typs assts =-          extractArgRetTypes-            Nothing-            False-            (CFunSig toplevelfunc_args toplevelfunc_ret)-        sig = tyForall Nothing (Just (cxTuple assts)) (foldr1 tyfun typs)-        xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull"-        cfname = "c_" <> toLowers fname-        rhs = app (mkVar xformerstr) (mkVar cfname)--    in mkFun fname sig [] rhs Nothing-genTopLevelFuncDef v@TopLevelVariable {..} =-    let fname = hsFrontNameForTopLevelFunction v-        cfname = "c_" <> toLowers fname-        rtyp = convertCpp2HS Nothing toplevelvar_ret-        sig = tyapp (tycon "IO") rtyp-        rhs = app (mkVar "xformnull") (mkVar cfname)--    in mkFun fname sig [] rhs Nothing------------------ Export -----------------genExport :: Class -> [ExportSpec ()]-genExport c =-    let espec n = if null . (filter isVirtualFunc) $ (class_funcs c)-                    then eabs nonamespace (unqual n)-                    else ethingall (unqual n)-    in if isAbstractClass c-       then [ espec (typeclassName c) ]-       else [ ethingall (unqual ((fst.hsClassName) c))-            , espec (typeclassName c)-            , evar (unqual ("upcast" <> (fst.hsClassName) c))-            , evar (unqual ("downcast" <> (fst.hsClassName) c)) ]-            <> genExportConstructorAndNonvirtual c-            <> genExportStatic c---- | constructor and non-virtual function-genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()]-genExportConstructorAndNonvirtual c = map (evar . unqual) fns-  where fs = class_funcs c-        fns = map (aliasedFuncName c) (constructorFuncs fs-                                       <> nonVirtualNotNewFuncs fs)---- | staic function export list-genExportStatic :: Class -> [ExportSpec ()]-genExportStatic c = map (evar . unqual) fns-  where fs = class_funcs c-        fns = map (aliasedFuncName c) (staticFuncs fs)------------------ Import -----------------genExtraImport :: ClassModule -> [ImportDecl ()]-genExtraImport cm = map mkImport (cmExtraImport cm)---genImportInModule :: [Class] -> [ImportDecl ()]-genImportInModule = concatMap (\x -> map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"])----genImportInInterface :: ClassModule -> [ImportDecl ()]-genImportInInterface m =-  let modlstraw = cmImportedModulesRaw m-      modlstparent = cmImportedModulesHighNonSource m-      modlsthigh = cmImportedModulesHighSource m-  in  [mkImport (cmModule m <.> "RawType")]-      <> flip map modlstraw-           (\case-               Left t -> mkImport (getTClassModuleBase t <.> "Template")-               Right c -> mkImport (getClassModuleBase c <.>"RawType")-           )-      <> flip map modlstparent-           (\case-               Left t -> mkImport (getTClassModuleBase t <.> "Template")-               Right c -> mkImport (getClassModuleBase c <.>"Interface")-           )-      <> flip map modlsthigh-           (\case-               Left t  -> -- TODO: *.Template in the same package needs to have hs-boot.-                          --       Currently, we do not have it yet.-                          mkImport (getTClassModuleBase t <.> "Template")-               Right c -> mkImportSrc (getClassModuleBase c<.>"Interface")-           )---- |-genImportInCast :: ClassModule -> [ImportDecl ()]-genImportInCast m = [ mkImport (cmModule m <.> "RawType")-                   ,  mkImport (cmModule m <.> "Interface") ]---- |-genImportInImplementation :: ClassModule -> [ImportDecl ()]-genImportInImplementation m =-  let modlstraw' = cmImportedModulesForFFI m-      modlsthigh = nub $ map Right $ concatMap class_allparents (cmClass m)-      modlstraw = filter (not.(flip elem modlsthigh)) modlstraw'-  in  [ mkImport (cmModule m <.> "RawType")-      , mkImport (cmModule m <.> "FFI")-      , mkImport (cmModule m <.> "Interface")-      , mkImport (cmModule m <.> "Cast") ]-      <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c<.>y)) ["RawType","Cast","Interface"]) modlstraw-      <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c<.>y)) ["RawType","Cast","Interface"]) modlsthigh----- | generate import list for a given top-level function---   currently this may generate duplicate import list.--- TODO: eliminate duplicated imports.-genImportForTopLevelFunction :: TopLevelFunction -> [ImportDecl ()]-genImportForTopLevelFunction f =-  let dep4func = extractClassDepForTopLevelFunction f-      ecs = returnDependency dep4func ++ argumentDependency dep4func-      cmods = nub $ map getClassModuleBase $ rights ecs-      tmods = nub $ map getTClassModuleBase $ lefts ecs-  in    concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) cmods-     <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["Template"]) tmods---- | generate import list for top level module-genImportInTopLevel ::-     String-  -> ([ClassModule],[TemplateClassModule])-  -> TopLevelImportHeader-  -> [ImportDecl ()]-genImportInTopLevel modname (mods,tmods) tih =-  let tfns = tihFuncs tih-  in    map (mkImport . cmModule) mods-     ++ if null tfns-        then []-        else    map mkImport [ "Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast" ]-             ++ map (\c -> mkImport (modname <.> (fst.hsClassName.cihClass) c <.> "RawType")) (tihClassDep tih)-             ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods-             ++ concatMap genImportForTopLevelFunction tfns-

@@ -1,180 +0,0 @@-{-# LANGUAGE RecordWildCards   #-}-module FFICXX.Generate.Code.HsTemplate where--import Data.Monoid                             ((<>))-import Language.Haskell.Exts.Build             (app,binds,doE,letE,letStmt,name,pApp-                                               ,qualStmt,strE,tuple)-import Language.Haskell.Exts.Syntax            (Decl(..))----import FFICXX.Generate.Code.Primitive          (functionSignatureT-                                               ,functionSignatureTT-                                               ,functionSignatureTMF)-import FFICXX.Generate.Code.HsCast             (castBody)-import FFICXX.Generate.Name                    (ffiTmplFuncName-                                               ,hsTemplateClassName-                                               ,hsTemplateMemberFunctionName-                                               ,hsTemplateMemberFunctionNameTH-                                               ,hsTmplFuncName-                                               ,hsTmplFuncNameTH-                                               ,typeclassNameT)-import FFICXX.Generate.Type.Class              (Class(..)-                                               ,TemplateClass(..)-                                               ,TemplateFunction(..)-                                               ,TemplateMemberFunction(..))-import FFICXX.Generate.Util.HaskellSrcExts     (bracketExp-                                               ,con,conDecl,cxEmpty-                                               ,generator-                                               ,clsDecl,insDecl,insType-                                               ,lambda,list-                                               ,mkBind1,mkTBind,mkData,mkNewtype-                                               ,mkFun,mkFunSig,mkClass,mkInstance-                                               ,mkPVar,mkTVar,mkVar-                                               ,pbind,qualConDecl-                                               ,tyapp,tycon,tyfun,tylist,tyPtr-                                               ,typeBracket)------------------------------------- Template member function -----------------------------------genTemplateMemberFunctions :: Class -> [Decl ()]-genTemplateMemberFunctions c =-  concatMap (\f -> genTMFExp c f <> genTMFInstance c f) (class_tmpl_funcs c)---genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()]-genTMFExp c f = mkFun nh sig [p "typ", p "suffix"] rhs (Just bstmts)-      where nh = hsTemplateMemberFunctionNameTH c f-            sig = tycon "Type" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tycon "Exp")))-            v = mkVar-            p = mkPVar-            tp = tmf_param f-            lit' = strE (hsTemplateMemberFunctionName c f <> "_")-            lam = lambda [p "n"] ( lit' `app` v "<>" `app` v "n")-            rhs = app (v "mkTFunc") (tuple [v "typ", v "suffix", lam, v "tyf"])-            sig' = functionSignatureTMF c f-            bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]-                               (letE [ pbind (p tp) (v "pure" `app` (v "typ")) Nothing ]-                                  (bracketExp (typeBracket sig')))-                               Nothing-                           ]---genTMFInstance :: Class -> TemplateMemberFunction -> [Decl ()]-genTMFInstance c f = mkFun fname sig [p "qtyp", p "suffix"] rhs Nothing-  where fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f-        p = mkPVar-        v = mkVar-        sig = (tyapp (tycon "Q") (tycon "Type")) `tyfun`-                (tycon "String" `tyfun`-                  (tyapp (tycon "Q") (tylist (tycon "Dec"))))-        rhs = doE [qtypstmt, genstmt, letStmt lststmt, qualStmt retstmt]-        qtypstmt = generator (p "typ") (v "qtyp")-        genstmt = generator-                    (p "f1")-                    (v "mkMember" `app` (     strE (hsTemplateMemberFunctionName c f <> "_")-                                        `app` v "<>"-                                        `app` v "suffix"-                                        )-                                  `app` v (hsTemplateMemberFunctionNameTH c f)-                                  `app` v "typ"-                                  `app` v "suffix"-                    )-        lststmt = [ pbind (p "lst") (list ([v "f1"])) Nothing ]-        retstmt = v "pure" `app` v "lst"------------------------- Template Class -------------------------genTmplInterface :: TemplateClass -> [Decl ()]-genTmplInterface t =-  [ mkData rname [mkTBind tp] [] Nothing-  , mkNewtype hname [mkTBind tp]-      [ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing-  , mkClass cxEmpty (typeclassNameT t) [mkTBind tp] methods-  , mkInstance cxEmpty "FPtr" [ hightype ] fptrbody-  , mkInstance cxEmpty "Castable" [ hightype, tyapp tyPtr rawtype ] castBody-  ]- where (hname,rname) = hsTemplateClassName t-       tp = tclass_param t-       fs = tclass_funcs t-       rawtype = tyapp (tycon rname) (mkTVar tp)-       hightype = tyapp (tycon hname) (mkTVar tp)-       sigdecl f = mkFunSig (hsTmplFuncName t f) (functionSignatureT t f)-       methods = map (clsDecl . sigdecl) fs-       fptrbody = [ insType (tyapp (tycon "Raw") hightype) rawtype-                  , insDecl (mkBind1 "get_fptr" [pApp (name hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)-                  , insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing)-                  ]---genTmplImplementation :: TemplateClass -> [Decl ()]-genTmplImplementation t = concatMap gen (tclass_funcs t)-  where-    gen f = mkFun nh sig [p "typ", p "suffix"] rhs (Just bstmts)-      where nh = hsTmplFuncNameTH t f-            nc = ffiTmplFuncName f-            sig = tycon "Type" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tycon "Exp")))-            v = mkVar-            p = mkPVar-            tp = tclass_param t-            prefix = tclass_name t-            lit' = strE (prefix<>"_"<>nc<>"_")-            lam = lambda [p "n"] ( lit' `app` v "<>" `app` v "n")-            rhs = app (v "mkTFunc") (tuple [v "typ", v "suffix", lam, v "tyf"])-            sig' = functionSignatureTT t f-            bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]-                               (letE [ pbind (p tp) (v "pure" `app` (v "typ")) Nothing ]-                                  (bracketExp (typeBracket sig')))-                               Nothing-                           ]---genTmplInstance :: TemplateClass -> [TemplateFunction] -> [Decl ()]-genTmplInstance t fs = mkFun fname sig [p "qtyp", p "suffix"] rhs Nothing-  where tname = tclass_name t-        fname = "gen" <> tname <> "InstanceFor"-        p = mkPVar-        v = mkVar-        sig = (tyapp (tycon "Q") (tycon "Type")) `tyfun`-                (tycon "String" `tyfun`-                  (tyapp (tycon "Q") (tylist (tycon "Dec"))))-        nfs = zip ([1..] :: [Int]) fs-        rhs = doE (  [qtypstmt]-                  <> map genstmt nfs-                  <> [letStmt (lststmt nfs), qualStmt retstmt])-        qtypstmt = generator (p "typ") (v "qtyp")-        genstmt (n,f@TFun    {..}) = generator-                                       (p ("f"<>show n))-                                       (v "mkMember" `app` strE (hsTmplFuncName t f)-                                                     `app` v    (hsTmplFuncNameTH t f)-                                                     `app` v    "typ"-                                                     `app` v    "suffix"-                                       )-        genstmt (n,f@TFunNew {..}) = generator-                                       (p ("f"<>show n))-                                       (v "mkNew"    `app` strE (hsTmplFuncName t f)-                                                     `app` v    (hsTmplFuncNameTH t f)-                                                     `app` v    "typ"-                                                     `app` v    "suffix"-                                       )-        genstmt (n,f@TFunDelete)   = generator-                                       (p ("f"<>show n))-                                       (v "mkDelete" `app` strE (hsTmplFuncName t f)-                                                     `app` v    (hsTmplFuncNameTH t f)-                                                     `app` v    "typ"-                                                     `app` v    "suffix"-                                       )-        lststmt xs = [ pbind (p "lst") (list (map (v . (\n->"f"<>show n) . fst) xs)) Nothing ]-        retstmt = v "pure"-                  `app` list [ v "mkInstance"-                               `app` list []-                               `app` (con "AppT"-                                      `app` (v "con" `app` strE (typeclassNameT t))-                                      `app` (v "typ")-                                     )-                               `app` (v "lst")-                             ]

@@ -1,882 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module FFICXX.Generate.Code.Primitive where--import           Control.Monad.Trans.State         (runState,put,get)-import           Data.Monoid                       ((<>))-import           Language.Haskell.Exts.Syntax      (Asst(..),Context,Type(..))----import           FFICXX.Generate.Name-import           FFICXX.Generate.Type.Class-import           FFICXX.Generate.Util-import           FFICXX.Generate.Util.HaskellSrcExts--data CFunSig = CFunSig { cArgTypes :: Args-                       , cRetType :: Types-                       }--data HsFunSig = HsFunSig { hsSigTypes :: [Type ()]-                         , hsSigConstraints :: [Asst ()]-                         }--cvarToStr :: CTypes -> IsConst -> String -> String-cvarToStr ctyp isconst varname = ctypToStr ctyp isconst <> " " <> varname--ctypToStr :: CTypes -> IsConst -> String-ctypToStr ctyp isconst =-  let typword = case ctyp of-        CTBool -> "bool"-        CTChar -> "char"-        CTClock -> "clock_t"-        CTDouble -> "double"-        CTFile -> "FILE"-        CTFloat -> "float"-        CTFpos -> "fpos_t"-        CTInt -> "int"-        CTIntMax -> "intmax_t"-        CTIntPtr -> "intptr_t"-        CTJmpBuf -> "jmp_buf"-        CTLLong -> "long long"-        CTLong -> "long"-        CTPtrdiff -> "ptrdiff_t"-        CTSChar -> "sized char"-        CTSUSeconds -> "suseconds_t"-        CTShort -> "short"-        CTSigAtomic -> "sig_atomic_t"-        CTSize -> "size_t"-        CTTime -> "time_t"-        CTUChar -> "unsigned char"-        CTUInt -> "unsigned int"-        CTUIntMax -> "uintmax_t"-        CTUIntPtr -> "uintptr_t"-        CTULLong -> "unsigned long long"-        CTULong -> "unsigned long"-        CTUSeconds -> "useconds_t"-        CTUShort -> "unsigned short"-        CTWchar -> "wchar_t"-        CTInt8 -> "int8_t"-        CTInt16 -> "int16_t"-        CTInt32 -> "int32_t"-        CTInt64 -> "int64_t"-        CTUInt8 -> "uint8_t"-        CTUInt16 -> "uint16_t"-        CTUInt32 -> "uint32_t"-        CTUInt64 -> "uint64_t"-        CTString -> "char*"-        CTVoidStar -> "void*"-        CEnum _ type_str -> type_str-        CPointer s -> ctypToStr s NoConst <> "*"-        CRef s -> ctypToStr s NoConst <> "*"-  in case isconst of-        Const   -> "const" <> " " <> typword-        NoConst -> typword--self_ :: Types-self_ = SelfType--cstring_ :: Types-cstring_ = CT CTString Const--cint_ :: Types-cint_    = CT CTInt    Const--int_ :: Types-int_     = CT CTInt    NoConst--uint_ :: Types-uint_ = CT CTUInt NoConst--ulong_ :: Types-ulong_ = CT CTULong NoConst--long_ :: Types-long_ = CT CTLong NoConst--culong_ :: Types-culong_ = CT CTULong Const--clong_ :: Types-clong_ = CT CTLong Const--cchar_ :: Types-cchar_ = CT CTChar Const--char_ :: Types-char_ = CT CTChar NoConst--cshort_ :: Types-cshort_ = CT CTShort Const--short_ :: Types-short_ = CT CTShort NoConst--cdouble_ :: Types-cdouble_ = CT CTDouble Const--double_ :: Types-double_  = CT CTDouble NoConst--doublep_ :: Types-doublep_ = CT (CPointer CTDouble) NoConst--cfloat_ :: Types-cfloat_ = CT CTFloat Const--float_ :: Types-float_ = CT CTFloat NoConst--bool_ :: Types-bool_    = CT CTBool   NoConst--void_ :: Types-void_ = Void--voidp_ :: Types-voidp_ = CT CTVoidStar NoConst--intp_ :: Types-intp_ = CT (CPointer CTInt) NoConst--intref_ :: Types-intref_ = CT (CRef CTInt) NoConst---charpp_ :: Types-charpp_ = CT (CPointer CTString) NoConst--ref_ :: CTypes -> Types-ref_ t = CT (CRef t) NoConst--star_ :: CTypes -> Types-star_ t = CT (CPointer t) NoConst--cstar_ :: CTypes -> Types-cstar_ t = CT (CPointer t) Const--self :: String -> (Types, String)-self var = (self_, var)--voidp :: String -> (Types,String)-voidp var = (voidp_ , var)--cstring :: String -> (Types,String)-cstring var = (cstring_ , var)--cint :: String -> (Types,String)-cint    var = (cint_    , var)--int :: String -> (Types,String)-int     var = (int_     , var)--uint :: String -> (Types,String)-uint var = (uint_ , var)--long :: String -> (Types,String)-long var = (long_, var)--ulong :: String -> (Types,String)-ulong var = (ulong_ , var)--clong :: String -> (Types,String)-clong var = (clong_, var)--culong :: String -> (Types,String)-culong var = (culong_ , var)--cchar :: String -> (Types,String)-cchar var = (cchar_ , var)--char :: String -> (Types,String)-char var = (char_ , var)--cshort :: String -> (Types,String)-cshort var = (cshort_ , var)--short :: String -> (Types,String)-short var = (short_ , var)--cdouble :: String -> (Types,String)-cdouble var = (cdouble_ , var)--double :: String -> (Types,String)-double  var = (double_  , var)--doublep :: String -> (Types,String)-doublep var = (doublep_ , var)--cfloat :: String -> (Types,String)-cfloat var = (float_ , var)--float :: String -> (Types,String)-float var = (float_ , var)--bool :: String -> (Types,String)-bool    var = (bool_    , var)--intp :: String -> (Types, String)-intp var = (intp_ , var)--intref :: String -> (Types, String)-intref var = (intref_, var)--charpp :: String -> (Types, String)-charpp var = (charpp_, var)--ref :: CTypes -> String -> (Types,String)-ref t var = (ref_ t, var)--star :: CTypes -> String -> (Types, String)-star t var = (star_ t, var)--cstar :: CTypes -> String -> (Types, String)-cstar t var = (cstar_ t, var)---cppclass_ :: Class -> Types-cppclass_ c =  CPT (CPTClass c) NoConst--cppclass :: Class -> String -> (Types, String)-cppclass c vname = ( cppclass_ c, vname)----cppclassconst :: Class -> String -> (Types, String)-cppclassconst c vname = ( CPT (CPTClass c) Const, vname)--cppclassref_ :: Class -> Types-cppclassref_ c = CPT (CPTClassRef c) NoConst--cppclassref :: Class -> String -> (Types, String)-cppclassref c vname = (cppclassref_ c, vname)--cppclasscopy_ :: Class -> Types-cppclasscopy_ c = CPT (CPTClassCopy c) NoConst--cppclasscopy :: Class -> String -> (Types, String)-cppclasscopy c vname = (cppclasscopy_ c, vname)--cppclassmove_ :: Class -> Types-cppclassmove_ c = CPT (CPTClassMove c) NoConst--cppclassmove :: Class -> String -> (Types, String)-cppclassmove c vname = (cppclassmove_ c, vname)---argToString :: (Types,String) -> String-argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname-argToString (SelfType, varname) = "Type ## _p " <> varname-argToString (CPT (CPTClass c) isconst, varname) = case isconst of-    Const   -> "const_" <> cname <> "_p " <> varname-    NoConst -> cname <> "_p " <> varname-  where cname = ffiClassName c-argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of-    Const   -> "const_" <> cname <> "_p " <> varname-    NoConst -> cname <> "_p " <> varname-  where cname = ffiClassName c-argToString (CPT (CPTClassCopy c) isconst, varname) = case isconst of-    Const   -> "const_" <> cname <> "_p " <> varname-    NoConst -> cname <> "_p " <> varname-  where cname = ffiClassName c-argToString (CPT (CPTClassMove c) isconst, varname) = case isconst of-    Const   -> "const_" <> cname <> "_p " <> varname-    NoConst -> cname <> "_p " <> varname-  where cname = ffiClassName c-argToString (TemplateApp     _, varname) = "void* " <> varname-argToString (TemplateAppRef  _, varname) = "void* " <> varname-argToString (TemplateAppMove _, varname) = "void* " <> varname-argToString t = error ("argToString: " <> show t)--argsToString :: Args -> String-argsToString args =-  let args' = (SelfType, "p") : args-  in  intercalateWith conncomma argToString args'--argsToStringNoSelf :: Args -> String-argsToStringNoSelf = intercalateWith conncomma argToString---- TODO: remove this function-argToCallString :: (Types,String) -> String-argToCallString = uncurry castC2Cpp---argsToCallString :: Args -> String-argsToCallString = intercalateWith conncomma argToCallString---- TODO: rename this function by castExpressionFrom/To or something like that.-rettypeToString :: Types -> String-rettypeToString (CT ctyp isconst)        = ctypToStr ctyp isconst-rettypeToString Void                     = "void"-rettypeToString SelfType                 = "Type ## _p"-rettypeToString (CPT (CPTClass c) _)     = ffiClassName c <> "_p"-rettypeToString (CPT (CPTClassRef c) _)  = ffiClassName c <> "_p"-rettypeToString (CPT (CPTClassCopy c) _) = ffiClassName c <> "_p"-rettypeToString (CPT (CPTClassMove c) _) = ffiClassName c <> "_p"-rettypeToString (TemplateApp     _)      = "void*"-rettypeToString (TemplateAppRef  _)      = "void*"-rettypeToString (TemplateAppMove _)      = "void*"-rettypeToString (TemplateType _)         = "void*"-rettypeToString (TemplateParam _)        = "Type ## _p"-rettypeToString (TemplateParamPointer _) = "Type ## _p"------ TODO: Rewrite this with static_cast-castC2Cpp :: Types -> String -> String-castC2Cpp t e =-  case t of-    CT  (CRef _)         _ -> "(*"<> e <> ")"-    CPT (CPTClass     c) _ -> "to_nonconst<" <> f <> "," <> f <> "_t>(" <> e <> ")"-                              where f = ffiClassName c-    CPT (CPTClassRef  c) _ -> "to_nonconstref<" <> f <> "," <> f <> "_t>(*" <> e <> ")"-                              where f = ffiClassName c-    CPT (CPTClassCopy c) _ -> "*(to_nonconst<" <> f <> "," <> f <> "_t>(" <> e <> "))"-                              where f = ffiClassName c-    CPT (CPTClassMove c) _ -> "std::move(to_nonconstref<" <> f <> "," <> f<> "_t>(*" <> e <> "))"-                              where f = ffiClassName c-    TemplateApp    p  -> "to_nonconst<" <> tapp_CppTypeForParam p <> ",void>(" <> e <> ")"-    TemplateAppRef p  -> "*( (" <> tapp_CppTypeForParam p <> "*) " <> e <> ")"-    TemplateAppMove p -> "std::move(*( (" <> tapp_CppTypeForParam p <> "*) " <> e <> "))"-    _                 -> e----- TODO: Rewrite this with static_cast---       Merge this with returnCpp after Void and simple type adjustment-castCpp2C :: Types -> String -> String-castCpp2C t e =-  case t of-    Void                   -> ""-    SelfType               -> "to_nonconst<Type ## _t, Type>((Type *)" <> e <> ")"-    CT (CRef _) _          -> "&(" <> e <> ")"-    CT _ _                 -> e-    CPT (CPTClass c) _     -> "to_nonconst<" <> f <> "_t," <> f <> ">((" <> f <> "*)" <> e <> ")"-                               where f = ffiClassName c-    CPT (CPTClassRef c) _  -> "to_nonconst<" <> f <> "_t," <> f <> ">(&(" <> e <> "))"-                               where f = ffiClassName c-    CPT (CPTClassCopy c) _ -> "to_nonconst<" <> f <> "_t," <> f <> ">(new " <> f <> "(" <> e <> "))"-                               where f = ffiClassName c-    CPT (CPTClassMove c) _ -> "std::move(to_nonconst<" <> f <> "_t," <> f <>">(&(" <> e <> ")))"-                               where f = ffiClassName c-    TemplateApp _          -> error "castCpp2C: TemplateApp"-                              -- g <> "* r = new " <> g <> "(" <> e <> "); "-                              --  <> "return (static_cast<void*>(r));"-    TemplateAppRef _       -> error "castCpp2C: TemplateAppRef"-                              -- g <> "* r = new " <> g <> "(" <> e <> "); "-                              -- <> "return (static_cast<void*>(r));"-    TemplateAppMove _      -> error "castCpp2C: TemplateAppMove"-    TemplateType _         -> error "castCpp2C: TemplateType"-    TemplateParam _        -> error "castCpp2C: TemplateParam"-                              -- if b then e-                              --      else "to_nonconst<Type ## _t, Type>((Type *)&(" <> e <> "))"-    TemplateParamPointer _ -> error "castCpp2C: TemplateParamPointer"-                              -- if b then "(" <> callstr <> ");"-                              --      else "to_nonconst<Type ## _t, Type>(" <> e <> ") ;"----tmplArgToString :: Bool -> TemplateClass -> (Types,String) -> String-tmplArgToString _ _  (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname-tmplArgToString _ t (SelfType, varname) = tclass_oname t <> "* " <> varname-tmplArgToString _ _ (CPT (CPTClass c) isconst, varname) =-  case isconst of-    Const   -> "const_" <> ffiClassName c <> "_p " <> varname-    NoConst -> ffiClassName c <> "_p " <> varname-tmplArgToString _ _ (CPT (CPTClassRef c) isconst, varname) =-  case isconst of-    Const   -> "const_" <> ffiClassName c <> "_p " <> varname-    NoConst -> ffiClassName c <> "_p " <> varname-tmplArgToString _ _ (CPT (CPTClassMove c) isconst, varname) =-  case isconst of-    Const   -> "const_" <> ffiClassName c <> "_p " <> varname-    NoConst -> ffiClassName c <> "_p " <> varname-tmplArgToString _ _ (TemplateApp     _, v) = "void* " <> v-tmplArgToString _ _ (TemplateAppRef  _, v) = "void* " <> v-tmplArgToString _ _ (TemplateAppMove _, v) = "void* " <> v-tmplArgToString _ _ (TemplateType   _,  v) = "void* " <> v-tmplArgToString True  _ (TemplateParam _,v) = "Type " <> v-tmplArgToString False _ (TemplateParam _,v) = "Type ## _p " <> v-tmplArgToString True  _ (TemplateParamPointer _,v) = "Type " <> v-tmplArgToString False _ (TemplateParamPointer _,v) = "Type ## _p " <> v-tmplArgToString _ _ _ = error "tmplArgToString: undefined"--tmplAllArgsToString :: Bool-                    -> Selfness-                    -> TemplateClass-                    -> Args-                    -> String-tmplAllArgsToString b s t args =-  let args' = case s of-                Self -> (TemplateType t, "p") : args-                NoSelf -> args-  in  intercalateWith conncomma (tmplArgToString b t) args'----tmplArgToCallString-  :: Bool  -- ^ is primitive type?-  -> (Types,String)-  -> String-tmplArgToCallString _ (CPT (CPTClass c) _,varname) =-  -- TODO: Rewrite this with static_cast.-  "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = ffiClassName c-tmplArgToCallString _ (CPT (CPTClassRef c) _,varname) =-  -- TODO: Rewrite this with static_cast.-  "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = ffiClassName c-tmplArgToCallString _ (CPT (CPTClassMove c) _,varname) =-  -- TODO: Rewrite this with static_cast.-  "std::move(to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>"))" where str = ffiClassName c-tmplArgToCallString _ (CT (CRef _) _,varname) = "(*"<> varname<> ")"-tmplArgToCallString _ (TemplateApp x,varname) =-  case tapp_tparam x of-    TArg_TypeParam p -> "static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> ")"-    _ -> -- TODO: Implement this.-         error "tmplArgToCallString: TemplateApp"-tmplArgToCallString _ (TemplateAppRef x,varname) =-  case tapp_tparam x of-    TArg_TypeParam p -> "*" <> "(static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> "))"-    _ -> -- TODO: Implement this.-         error "tmplArgToCallString: TemplateAppRef"-tmplArgToCallString _ (TemplateAppMove x,varname) =-  case tapp_tparam x of-    TArg_TypeParam p -> "std::move(*" <> "(static_cast<" <> tclass_oname (tapp_tclass x) <> "<Type>*>(" <> varname <> ")))"-    _ -> -- TODO: Implement this.-         error "tmplArgToCallString: TemplateAppMove"-tmplArgToCallString b (TemplateParam _,varname) =-  case b of-    True  -> varname-    False -> "*(to_nonconst<Type,Type ## _t>(" <> varname <> "))"-tmplArgToCallString b (TemplateParamPointer _,varname) =-  case b of-    True  -> varname-    False -> "to_nonconst<Type,Type ## _t>(" <> varname <> ")"-tmplArgToCallString _ (_,varname) = varname--tmplAllArgsToCallString-  :: Bool  -- ^ is primitive type?-  -> Args-  -> String-tmplAllArgsToCallString b = intercalateWith conncomma (tmplArgToCallString b)----tmplRetTypeToString :: Bool   -- ^ is primitive type?-                    -> Types-                    -> String-tmplRetTypeToString _ (CT ctyp isconst)        = ctypToStr ctyp isconst-tmplRetTypeToString _ Void                     = "void"-tmplRetTypeToString _ SelfType                 = "void*"-tmplRetTypeToString _ (CPT (CPTClass c) _)     = ffiClassName c <> "_p"-tmplRetTypeToString _ (CPT (CPTClassRef c) _)  = ffiClassName c <> "_p"-tmplRetTypeToString _ (CPT (CPTClassCopy c) _) = ffiClassName c <> "_p"-tmplRetTypeToString _ (CPT (CPTClassMove c) _) = ffiClassName c <> "_p"-tmplRetTypeToString _ (TemplateApp     _)      = "void*"-tmplRetTypeToString _ (TemplateAppRef  _)      = "void*"-tmplRetTypeToString _ (TemplateAppMove _)      = "void*"-tmplRetTypeToString _ (TemplateType _)         = "void*"-tmplRetTypeToString b (TemplateParam _)        = if b then "Type" else "Type ## _p"-tmplRetTypeToString b (TemplateParamPointer _) = if b then "Type" else "Type ## _p"-------- ------------------------------ Template Member Function ----- -----------------------------tmplMemFuncArgToString :: Class -> (Types,String) -> String-tmplMemFuncArgToString _  (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname-tmplMemFuncArgToString c (SelfType, varname) = ffiClassName c <> "_p " <> varname-tmplMemFuncArgToString _ (CPT (CPTClass c) isconst, varname) =-  case isconst of-    Const   -> "const_" <> ffiClassName c <> "_p " <> varname-    NoConst -> ffiClassName c <> "_p " <> varname-tmplMemFuncArgToString _ (CPT (CPTClassRef c) isconst, varname) =-  case isconst of-    Const   -> "const_" <> ffiClassName c <> "_p " <> varname-    NoConst -> ffiClassName c <> "_p " <> varname-tmplMemFuncArgToString _ (CPT (CPTClassMove c) isconst, varname) =-  case isconst of-    Const   -> "const_" <> ffiClassName c <> "_p " <> varname-    NoConst -> ffiClassName c <> "_p " <> varname-tmplMemFuncArgToString _ (TemplateApp     _, v) = "void* " <> v-tmplMemFuncArgToString _ (TemplateAppRef  _, v) = "void* " <> v-tmplMemFuncArgToString _ (TemplateAppMove _, v) = "void* " <> v-tmplMemFuncArgToString _ (TemplateType   _,  v) = "void* " <> v-tmplMemFuncArgToString _ (TemplateParam _,v) = "Type##_p " <> v-tmplMemFuncArgToString _ (TemplateParamPointer _,v) = "Type##_p " <> v-tmplMemFuncArgToString _ _ = error "tmplMemFuncArgToString: undefined"---tmplMemFuncRetTypeToString :: Class -> Types -> String-tmplMemFuncRetTypeToString _ (CT ctyp isconst)        = ctypToStr ctyp isconst-tmplMemFuncRetTypeToString _ Void                     = "void"-tmplMemFuncRetTypeToString c SelfType                 = ffiClassName c <> "_p"-tmplMemFuncRetTypeToString _ (CPT (CPTClass c) _)     = ffiClassName c <> "_p"-tmplMemFuncRetTypeToString _ (CPT (CPTClassRef c) _)  = ffiClassName c <> "_p"-tmplMemFuncRetTypeToString _ (CPT (CPTClassCopy c) _) = ffiClassName c <> "_p"-tmplMemFuncRetTypeToString _ (CPT (CPTClassMove c) _) = ffiClassName c <> "_p"-tmplMemFuncRetTypeToString _ (TemplateApp     _)      = "void*"-tmplMemFuncRetTypeToString _ (TemplateAppRef  _)      = "void*"-tmplMemFuncRetTypeToString _ (TemplateAppMove _)      = "void*"-tmplMemFuncRetTypeToString _ (TemplateType _)         = "void*"-tmplMemFuncRetTypeToString _ (TemplateParam _)        = "Type##_p"-tmplMemFuncRetTypeToString _ (TemplateParamPointer _) = "Type##_p"------ |-convertC2HS :: CTypes -> Type ()-convertC2HS CTBool      = tycon "CBool"-convertC2HS CTChar      = tycon "CChar"-convertC2HS CTClock     = tycon "CClock"-convertC2HS CTDouble    = tycon "CDouble"-convertC2HS CTFile      = tycon "CFile"-convertC2HS CTFloat     = tycon "CFloat"-convertC2HS CTFpos      = tycon "CFpos"-convertC2HS CTInt       = tycon "CInt"-convertC2HS CTIntMax    = tycon "CIntMax"-convertC2HS CTIntPtr    = tycon "CIntPtr"-convertC2HS CTJmpBuf    = tycon "CJmpBuf"-convertC2HS CTLLong     = tycon "CLLong"-convertC2HS CTLong      = tycon "CLong"-convertC2HS CTPtrdiff   = tycon "CPtrdiff"-convertC2HS CTSChar     = tycon "CSChar"-convertC2HS CTSUSeconds = tycon "CSUSeconds"-convertC2HS CTShort     = tycon "CShort"-convertC2HS CTSigAtomic = tycon "CSigAtomic"-convertC2HS CTSize      = tycon "CSize"-convertC2HS CTTime      = tycon "CTime"-convertC2HS CTUChar     = tycon "CUChar"-convertC2HS CTUInt      = tycon "CUInt"-convertC2HS CTUIntMax   = tycon "CUIntMax"-convertC2HS CTUIntPtr   = tycon "CUIntPtr"-convertC2HS CTULLong    = tycon "CULLong"-convertC2HS CTULong     = tycon "CULong"-convertC2HS CTUSeconds  = tycon "CUSeconds"-convertC2HS CTUShort    = tycon "CUShort"-convertC2HS CTWchar     = tycon "CWchar"-convertC2HS CTInt8      = tycon "Int8"-convertC2HS CTInt16      = tycon "Int16"-convertC2HS CTInt32      = tycon "Int32"-convertC2HS CTInt64      = tycon "Int64"-convertC2HS CTUInt8      = tycon "Word8"-convertC2HS CTUInt16      = tycon "Word16"-convertC2HS CTUInt32      = tycon "Word32"-convertC2HS CTUInt64      = tycon "Word64"-convertC2HS CTString    = tycon "CString"-convertC2HS CTVoidStar   = tyapp (tycon "Ptr") unit_tycon-convertC2HS (CEnum t _)  = convertC2HS t-convertC2HS (CPointer t) = tyapp (tycon "Ptr") (convertC2HS t)-convertC2HS (CRef t)     = tyapp (tycon "Ptr") (convertC2HS t)---- |-convertCpp2HS :: Maybe Class -> Types -> Type ()-convertCpp2HS _c Void                  = unit_tycon-convertCpp2HS (Just c) SelfType        = tycon ((fst.hsClassName) c)-convertCpp2HS Nothing SelfType         = error "convertCpp2HS : SelfType but no class "-convertCpp2HS _c (CT t _)              = convertC2HS t-convertCpp2HS _c (CPT (CPTClass c') _)     = (tycon . fst . hsClassName) c'-convertCpp2HS _c (CPT (CPTClassRef c') _)  = (tycon . fst . hsClassName) c'-convertCpp2HS _c (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c'-convertCpp2HS _c (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c'-convertCpp2HS _c (TemplateApp x)     = tyapp-                                         (tycon (tclass_name (tapp_tclass x)))-                                         (tycon (hsClassNameForTArg (tapp_tparam x)))-convertCpp2HS _c (TemplateAppRef x)  = tyapp-                                         (tycon (tclass_name (tapp_tclass x)))-                                         (tycon (hsClassNameForTArg (tapp_tparam x)))-convertCpp2HS _c (TemplateAppMove x) = tyapp-                                         (tycon (tclass_name (tapp_tclass x)))-                                         (tycon (hsClassNameForTArg (tapp_tparam x)))-convertCpp2HS _c (TemplateType t)    = tyapp-                                         (tycon (tclass_name t))-                                         (mkTVar (tclass_param t))-convertCpp2HS _c (TemplateParam p)         = mkTVar p-convertCpp2HS _c (TemplateParamPointer p)  = mkTVar p---- |-convertCpp2HS4Tmpl-  :: Type ()    -- ^ self-  -> Maybe Class-  -> Type ()    -- ^ type paramemter splice-  -> Types-  -> Type ()-convertCpp2HS4Tmpl _ _c _ Void                  = unit_tycon-convertCpp2HS4Tmpl _ (Just c) _ SelfType        = tycon ((fst.hsClassName) c)-convertCpp2HS4Tmpl _ Nothing _ SelfType         = error "convertCpp2HS4Tmpl : SelfType but no class "-convertCpp2HS4Tmpl _ _c _ (CT t _)              = convertC2HS t-convertCpp2HS4Tmpl _ _c _ (CPT (CPTClass c') _)     = (tycon . fst . hsClassName) c'-convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassRef c') _)  = (tycon . fst . hsClassName) c'-convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c'-convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c'-convertCpp2HS4Tmpl e c s x@(TemplateApp p) =-  case tapp_tparam p of-    TArg_TypeParam _ -> let t = tapp_tclass p-                            (hname,_) = hsTemplateClassName t-                        in tyapp (tycon hname) s-    _ -> convertCpp2HS c x-convertCpp2HS4Tmpl e c s x@(TemplateAppRef p) =-  case tapp_tparam p of-    TArg_TypeParam _ -> let t = tapp_tclass p-                            (hname,_) = hsTemplateClassName t-                        in tyapp (tycon hname) s-    _ -> convertCpp2HS c x-convertCpp2HS4Tmpl e c s x@(TemplateAppMove p) =-  case tapp_tparam p of-    TArg_TypeParam _ -> let t = tapp_tclass p-                            (hname,_) = hsTemplateClassName t-                        in tyapp (tycon hname) s-    _ -> convertCpp2HS c x-convertCpp2HS4Tmpl e _c _ (TemplateType _)          = e-convertCpp2HS4Tmpl _ _c s (TemplateParam _)         = s-convertCpp2HS4Tmpl _ _c s (TemplateParamPointer _)  = s---hsFuncXformer :: Function -> String-hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func)-                                       in if len > 0-                                          then "xform" <> show (len - 1)-                                          else "xformnull"-hsFuncXformer func@(Static _ _ _ _) =-  let len = length (genericFuncArgs func)-  in if len > 0-     then "xform" <> show (len - 1)-     else "xformnull"-hsFuncXformer func = let len = length (genericFuncArgs func)-                     in "xform" <> show len----classConstraints :: Class -> Context ()-classConstraints = cxTuple . map ((\n->classA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents--extractArgRetTypes-  :: Maybe Class  -- ^ class (Nothing for top-level function)-  -> Bool         -- ^ is virtual function?-  -> CFunSig      -- ^ C type signature information for a given function      -- (Args,Types)           -- ^ (argument types, return type) of a given function-  -> HsFunSig     -- ^ Haskell type signature information for the function    --   ([Type ()],[Asst ()])  -- ^ (types, class constraints)-extractArgRetTypes mc isvirtual (CFunSig args ret) =-  let  (typs,s) = flip runState ([],(0 :: Int)) $ do-                    as <- mapM (mktyp . fst) args-                    r <- case ret of-                           SelfType -> case mc of-                                         Nothing -> error "extractArgRetTypes: SelfType return but no class"-                                         Just c -> if isvirtual then return (mkTVar "a") else return $ tycon ((fst.hsClassName) c)-                           x -> (return . convertCpp2HS Nothing) x-                    return (as ++ [tyapp (tycon "IO") r])-  in   HsFunSig { hsSigTypes = typs-                , hsSigConstraints = fst s-                }- where addclass c = do-         (ctxts,n) <- get-         let cname = (fst.hsClassName) c-             iname = typeclassNameFromStr cname-             tvar = mkTVar ('c' : show n)-             ctxt1 = classA (unqual iname) [tvar]-             ctxt2 = classA (unqual "FPtr") [tvar]-         put (ctxt1:ctxt2:ctxts,n+1)-         return tvar-       addstring = do-         (ctxts,n) <- get-         let tvar = mkTVar ('c' : show n)-             ctxt = classA (unqual "Castable") [tvar,tycon "CString"]-         put (ctxt:ctxts,n+1)-         return tvar--       mktyp typ =-         case typ of-           SelfType -> return (mkTVar "a")-           CT CTString Const -> addstring-           CT _ _   -> return $ convertCpp2HS Nothing typ-           CPT (CPTClass c') _    -> addclass c'-           CPT (CPTClassRef c') _ -> addclass c'-           CPT (CPTClassCopy c') _ -> addclass c'-           CPT (CPTClassMove c') _ -> addclass c'-           -- it is not clear whether the following is okay or not.-           (TemplateApp x)    -> pure $-                                   tyapp-                                     (tycon (tclass_name (tapp_tclass x)))-                                     (tycon (hsClassNameForTArg (tapp_tparam x)))-           (TemplateAppRef x) -> pure $-                                   tyapp-                                     (tycon (tclass_name (tapp_tclass x)))-                                     (tycon (hsClassNameForTArg (tapp_tparam x)))-           (TemplateAppMove x)-> pure $-                                   tyapp-                                     (tycon (tclass_name (tapp_tclass x)))-                                     (tycon (hsClassNameForTArg (tapp_tparam x)))-           (TemplateType t)   -> pure $-                                   tyapp-                                     (tycon (tclass_name t))-                                     (mkTVar (tclass_param t))-           (TemplateParam p)      -> return (mkTVar p)-           Void -> return unit_tycon-           _ -> error ("No such c type : " <> show typ)--functionSignature :: Class -> Function -> Type ()-functionSignature c f =-  let HsFunSig typs assts = extractArgRetTypes-                              (Just c)-                              (isVirtualFunc f)-                              (CFunSig (genericFuncArgs f) (genericFuncRet f))-      ctxt = cxTuple assts-      arg0-        | isVirtualFunc f    = (mkTVar "a" :)-        | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :)-        | otherwise          = id-  in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs))--functionSignatureT :: TemplateClass -> TemplateFunction -> Type ()-functionSignatureT t TFun {..} =-  let (hname,_) = hsTemplateClassName t-      tp = tclass_param t-      ctyp = convertCpp2HS Nothing tfun_ret-      arg0 =  (tyapp (tycon hname) (mkTVar tp) :)-      lst = arg0 (map (convertCpp2HS Nothing . fst) tfun_args)-  in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])-functionSignatureT t TFunNew {..} =-  let ctyp = convertCpp2HS Nothing (TemplateType t)-      lst = map (convertCpp2HS Nothing . fst) tfun_new_args-  in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])-functionSignatureT t TFunDelete =-  let ctyp = convertCpp2HS Nothing (TemplateType t)-  in ctyp `tyfun` (tyapp (tycon "IO") unit_tycon)------ TODO: rename this and combine this with functionSignatureTMF-functionSignatureTT :: TemplateClass -> TemplateFunction -> Type ()-functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])- where-  (hname,_) = hsTemplateClassName t-  ctyp = case f of-           TFun {..}    -> convertCpp2HS4Tmpl e Nothing spl tfun_ret-           TFunNew {..} -> convertCpp2HS4Tmpl e Nothing spl (TemplateType t)-           TFunDelete   -> unit_tycon-  e = tyapp (tycon hname) spl-  spl = tySplice (parenSplice (mkVar (tclass_param t)))-  lst =-    case f of-      TFun {..}    -> e : map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_args-      TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_new_args-      TFunDelete -> [e]---- TODO: rename this and combine this with functionSignatureTT-functionSignatureTMF :: Class -> TemplateMemberFunction -> Type ()-functionSignatureTMF c f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])-  where-    ctyp = convertCpp2HS4Tmpl e Nothing spl (tmf_ret f)-    e = tycon (fst (hsClassName c))-    spl = tySplice (parenSplice (mkVar (tmf_param f)))-    lst = e : map (convertCpp2HS4Tmpl e Nothing spl . fst) (tmf_args f)---accessorCFunSig :: Types -> Accessor -> CFunSig-accessorCFunSig typ Getter = CFunSig [] typ-accessorCFunSig typ Setter = CFunSig [(typ,"x")] Void---accessorSignature :: Class -> Variable -> Accessor -> Type ()-accessorSignature c v accessor =-  let csig = accessorCFunSig (var_type v) accessor-      HsFunSig typs assts = extractArgRetTypes (Just c) False csig-      ctxt = cxTuple assts-      arg0 = (mkTVar (fst (hsClassName c)) :)-  in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs))----- | this is for FFI type.-hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type ()-hsFFIFuncTyp msc (CFunSig args ret) =-  foldr1 tyfun $ case msc of-                   Nothing         -> argtyps <> [tyapp (tycon "IO") rettyp]-                   Just (Self,_)   -> selftyp: argtyps <> [tyapp (tycon "IO") rettyp]-                   Just (NoSelf,_) -> argtyps <> [tyapp (tycon "IO") rettyp]-  where argtyps :: [Type ()]-        argtyps = map (hsargtype . fst) args-        rettyp :: Type ()-        rettyp  = hsrettype ret-        selftyp = case msc of-                    Just (_,c) -> tyapp tyPtr (tycon (snd (hsClassName c)))-                    Nothing    -> error "hsFFIFuncTyp: no self for top level function"-        hsargtype :: Types -> Type ()-        hsargtype (CT ctype _)               = convertC2HS ctype-        hsargtype (CPT (CPTClass d) _)       = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsargtype (CPT (CPTClassRef d) _)    = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsargtype (CPT (CPTClassMove d) _)    = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsargtype (CPT (CPTClassCopy d) _)    = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsargtype (TemplateApp x)   = tyapp-                                        tyPtr-                                        (tyapp-                                           (tycon rawname)-                                           (tycon (hsClassNameForTArg (tapp_tparam x))))-          where rawname = snd (hsTemplateClassName (tapp_tclass x))-        hsargtype (TemplateAppRef x) = tyapp-                                         tyPtr-                                         (tyapp-                                            (tycon rawname)-                                            (tycon (hsClassNameForTArg (tapp_tparam x))))-          where rawname = snd (hsTemplateClassName (tapp_tclass x))-        hsargtype (TemplateAppMove x)= tyapp-                                         tyPtr-                                         (tyapp-                                            (tycon rawname)-                                            (tycon (hsClassNameForTArg (tapp_tparam x))))-          where rawname = snd (hsTemplateClassName (tapp_tclass x))-        hsargtype (TemplateType t)           = tyapp tyPtr (tyapp (tycon rawname) (mkTVar (tclass_param t)))-          where rawname = snd (hsTemplateClassName t)-        hsargtype (TemplateParam p)          = mkTVar p-        hsargtype SelfType                   = selftyp-        hsargtype _ = error "hsFuncTyp: undefined hsargtype"-        ----------------------------------------------------------        hsrettype Void                       = unit_tycon-        hsrettype SelfType                   = selftyp-        hsrettype (CT ctype _)               = convertC2HS ctype-        hsrettype (CPT (CPTClass d) _)       = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsrettype (CPT (CPTClassRef d) _)    = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsrettype (CPT (CPTClassCopy d) _)   = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsrettype (CPT (CPTClassMove d) _)   = tyapp tyPtr (tycon rawname)-          where rawname = snd (hsClassName d)-        hsrettype (TemplateApp x)    = tyapp-                                         tyPtr-                                         (tyapp-                                            (tycon rawname)-                                            (tycon (hsClassNameForTArg (tapp_tparam x))))-          where rawname = snd (hsTemplateClassName (tapp_tclass x))-        hsrettype (TemplateAppRef x) = tyapp-                                         tyPtr-                                         (tyapp-                                            (tycon rawname)-                                            (tycon (hsClassNameForTArg (tapp_tparam x))))-          where rawname = snd (hsTemplateClassName (tapp_tclass x))-        hsrettype (TemplateAppMove x)= tyapp-                                         tyPtr-                                         (tyapp-                                            (tycon rawname)-                                            (tycon (hsClassNameForTArg (tapp_tparam x))))-          where rawname = snd (hsTemplateClassName (tapp_tclass x))-        hsrettype (TemplateType t)           = tyapp tyPtr (tyapp (tycon rawname) (mkTVar (tclass_param t)))-          where rawname = snd (hsTemplateClassName t)-        hsrettype (TemplateParam p)          = mkTVar p-        hsrettype (TemplateParamPointer p)   = mkTVar p----genericFuncRet :: Function -> Types-genericFuncRet f =-  case f of-    Constructor _ _ -> self_-    Virtual t _ _ _ -> t-    NonVirtual t _ _ _-> t-    Static t _ _ _ -> t-    Destructor _ -> void_--genericFuncArgs :: Function -> Args-genericFuncArgs (Destructor _) = []-genericFuncArgs f = func_args f

@@ -1,39 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Config--- Copyright   : (c) 2011-2019 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC------------------------------------------------------------------------------------module FFICXX.Generate.Config where--import FFICXX.Generate.Type.Cabal            ( Cabal )-import FFICXX.Generate.Type.Class            ( Class, TemplateClass, TopLevelFunction )-import FFICXX.Generate.Type.Config           ( ModuleUnitMap(..) )-import FFICXX.Generate.Type.PackageInterface ( HeaderName )---data FFICXXConfig = FFICXXConfig {-    fficxxconfig_workingDir     :: FilePath-  , fficxxconfig_installBaseDir :: FilePath-  , fficxxconfig_staticFileDir  :: FilePath-  } deriving Show--data SimpleBuilderConfig =-  SimpleBuilderConfig {-    sbcTopModule     :: String-  , sbcModUnitMap    :: ModuleUnitMap-  , sbcCabal         :: Cabal-  , sbcClasses       :: [Class]-  , sbcTopLevels     :: [TopLevelFunction]-  , sbcTemplates     :: [(TemplateClass,HeaderName)]-  , sbcExtraLibs     :: [String]-  , sbcExtraDeps     :: [(String,[String])]-  , sbcStaticFiles   :: [String]-  }

@@ -1,485 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.ContentMaker--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.ContentMaker where--import           Control.Lens                           ((&),(.~),at)-import           Control.Monad.Trans.Reader-import           Data.Char                              (toUpper)-import           Data.Either                            (rights)-import           Data.Function                          (on)-import qualified Data.Map                          as M-import           Data.Monoid                            ((<>))-import           Data.List                              (intercalate,nub,nubBy)-import           Data.List.Split                        (splitOn)-import           Data.Maybe-import           Data.Text                              (Text)-import           Language.Haskell.Exts.Syntax           (Module(..),Decl(..))-import           System.FilePath----import           FFICXX.Generate.Code.Cpp-import           FFICXX.Generate.Code.HsCast            (genHsFrontInstCastable-                                                        ,genHsFrontInstCastableSelf)-import           FFICXX.Generate.Code.HsFFI             (genHsFFI-                                                        ,genImportInFFI-                                                        ,genTopLevelFuncFFI)-import           FFICXX.Generate.Code.HsFrontEnd-import           FFICXX.Generate.Code.HsTemplate        (genTemplateMemberFunctions-                                                        ,genTmplInstance-                                                        ,genTmplInterface-                                                        ,genTmplImplementation-                                                        )-import           FFICXX.Generate.Dependency-import           FFICXX.Generate.Name                   (ffiClassName,hsClassName-                                                        ,hsFrontNameForTopLevelFunction)-import           FFICXX.Generate.Type.Annotate-import           FFICXX.Generate.Type.Class-import           FFICXX.Generate.Type.Module-import           FFICXX.Generate.Type.PackageInterface  (ClassName(..),HeaderName(..)-                                                        ,Namespace(..)-                                                        ,PackageInterface,PackageName(..)-                                                        ,TypeMacro(..))-import           FFICXX.Generate.Util-import           FFICXX.Generate.Util.HaskellSrcExts------srcDir :: FilePath -> FilePath-srcDir installbasedir = installbasedir </> "src"--csrcDir :: FilePath -> FilePath-csrcDir installbasedir = installbasedir </> "csrc"------ common function for daughter---- |-mkGlobal :: [Class] -> ClassGlobal-mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap----- |-buildDaughterDef :: ((String,[Class]) -> String)-              -> DaughterMap-              -> String-buildDaughterDef f m =-    let lst = M.toList m-        f' (x,xs) =  f (x,filter (not.isAbstractClass) xs)-    in (concatMap f' lst)---- |-buildParentDef :: ((Class,Class)->String) -> Class -> String-buildParentDef f cls = g (class_allparents cls,cls)-  where g (ps,c) = concatMap (\p -> f (p,c)) ps---- |-mkProtectedFunctionList :: Class -> String-mkProtectedFunctionList c =-    (unlines-     . map (\x->"#define IS_" <> class_name c <> "_" <> x <> "_PROTECTED ()")-     . unProtected . class_protected) c---- |-buildTypeDeclHeader :: TypeMacro -- ^ typemacro-                 -> [Class]-                 -> String-buildTypeDeclHeader (TypMcro typemacro) classes =-  let typeDeclBodyStr = intercalateWith connRet2 (genCppHeaderMacroType) classes-  in subst-       "#ifdef __cplusplus\n\-       \extern \"C\" { \n\-       \#endif\n\-       \\n\-       \#ifndef $typemacro\n\-       \#define $typemacro\n\-       \\n\-       \$typeDeclBody\n\-       \\n\-       \#endif // $typemacro\n\-       \\n\-       \#ifdef __cplusplus\n\-       \}\n\-       \#endif\n"-       (context [ ("typeDeclBody", typeDeclBodyStr )-                , ("typemacro"   , typemacro       ) ])----declarationTemplate :: Text-declarationTemplate =-  "#ifdef __cplusplus\n\-  \extern \"C\" { \n\-  \#endif\n\-  \\n\-  \#ifndef $typemacro\n\-  \#define $typemacro\n\-  \\n\-  \#include \"${cprefix}Type.h\"\n\-  \ // \n\-  \$declarationheader\n\-  \ // \n\-  \$declarationbody\n\-  \\n\-  \#endif // $typemacro\n\-  \\n\-  \#ifdef __cplusplus\n\-  \}\n\-  \#endif\n"---- |-buildDeclHeader :: TypeMacro  -- ^ typemacro prefix-             -> String     -- ^ C prefix-             -> ClassImportHeader-             -> String-buildDeclHeader (TypMcro typemacroprefix) cprefix header =-  let classes = [cihClass header]-      aclass = cihClass header-      typemacrostr = typemacroprefix <> ffiClassName aclass <> "__"-      declHeaderStr = intercalateWith-                        connRet-                        (\x->"#include \""<>x<>"\"")-                        (map unHdrName (cihIncludedHPkgHeadersInH header))-      declDefStr    = intercalateWith connRet2 genCppHeaderMacroVirtual classes-                      `connRet2`-                      intercalateWith connRet genCppHeaderMacroNonVirtual classes-                      `connRet2`-                      intercalateWith connRet genCppHeaderMacroAccessor classes-                      `connRet2`-                      intercalateWith connRet2 genCppDefMacroVirtual classes-                      `connRet2`-                      intercalateWith connRet2 genCppDefMacroNonVirtual classes-                      `connRet2`-                      intercalateWith connRet2 genCppDefMacroAccessor classes-                      `connRet2`-                      flip (intercalateWith connRet2) classes-                        (\c -> intercalateWith connRet2-                                 (genCppDefMacroTemplateMemberFunction c)-                                 (class_tmpl_funcs c)-                        )-      classDeclsStr = -- NOTE: Deletable is treated specially.-                      -- TODO: We had better make it as a separate constructor in Class.-                      if (fst.hsClassName) aclass /= "Deletable"-                        then buildParentDef genCppHeaderInstVirtual aclass-                             `connRet2`-                             genCppHeaderInstVirtual (aclass, aclass)-                             `connRet2`-                             intercalateWith connRet genCppHeaderInstNonVirtual classes-                             `connRet2`-                             intercalateWith connRet genCppHeaderInstAccessor classes-                        else ""-      declBodyStr   = declDefStr-                      `connRet2`-                      classDeclsStr-  in subst declarationTemplate-       (context [ ("typemacro"        , typemacrostr  )-                , ("cprefix"          , cprefix       )-                , ("declarationheader", declHeaderStr )-                , ("declarationbody"  , declBodyStr   ) ])---definitionTemplate :: Text-definitionTemplate =-  "#include<MacroPatternMatch.h>\n\-  \$header\n\-  \\n\-  \$namespace\n\-  \\n\-  \$alias\n\-  \\n\-  \#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n\-  \\n\-  \#define TYPECASTMETHOD(cname,mname,oname) \\\n\-  \  IIF( CHECKPROTECT(cname,mname) ) ( \\\n\-  \  (to_nonconst<oname,cname ## _t>), \\\n\-  \  (to_nonconst<cname,cname ## _t>) )\n\-  \\n\-  \$cppbody\n"----- |-buildDefMain :: ClassImportHeader-          -> String-buildDefMain cih =-  let classes = [cihClass cih]-      headerStr = genAllCppHeaderInclude cih <> "\n#include \"" <> (unHdrName (cihSelfHeader cih)) <> "\""-      namespaceStr = (concatMap (\x->"using namespace " <> unNamespace x <> ";\n") . cihNamespace) cih-      aclass = cihClass cih-      aliasStr = intercalate "\n" $-                   mapMaybe typedefstmt $-                     aclass : rights (cihImportedClasses cih)-        where typedefstmt c = let n1 = class_name c-                                  n2 = ffiClassName c-                              in if n1 == n2-                                 then Nothing-                                 else Just ("typedef " <> n1 <> " " <> n2 <> ";")--      cppBody = mkProtectedFunctionList (cihClass cih)-                `connRet`-                buildParentDef genCppDefInstVirtual (cihClass cih)-                `connRet`-                if isAbstractClass aclass-                  then ""-                  else genCppDefInstVirtual (aclass, aclass)-                `connRet`-                intercalateWith connRet genCppDefInstNonVirtual classes-                `connRet`-                intercalateWith connRet genCppDefInstAccessor classes-  in subst definitionTemplate (context ([ ("header"   , headerStr    )-                                        , ("alias"    , aliasStr     )-                                        , ("namespace", namespaceStr )-                                        , ("cppbody"  , cppBody      ) ]))---- |-buildTopLevelHeader :: TypeMacro  -- ^ typemacro prefix-                    -> String     -- ^ C prefix-                    -> TopLevelImportHeader-                    -> String-buildTopLevelHeader (TypMcro typemacroprefix) cprefix tih =-  let typemacrostr = typemacroprefix <> "TOPLEVEL" <> "__"-      declHeaderStr = intercalateWith connRet (\x->"#include \""<>x<>"\"") $-                        map unHdrName $-                                 map cihSelfHeader (tihClassDep tih)-                              ++ tihExtraHeadersInH tih-      declBodyStr    = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih)-  in subst declarationTemplate (context [ ("typemacro"        , typemacrostr  )-                                        , ("cprefix"          , cprefix       )-                                        , ("declarationheader", declHeaderStr )-                                        , ("declarationbody"  , declBodyStr   ) ])---- |-buildTopLevelCppDef :: TopLevelImportHeader -> String-buildTopLevelCppDef tih =-  let cihs = tihClassDep tih-      extclasses = tihExtraClassDep tih-      declHeaderStr = "#include \"" <> tihHeaderFileName tih <.> "h" <> "\""-                      `connRet2`-                      (intercalate "\n" (nub (map genAllCppHeaderInclude cihs)))-                      `connRet2`-                      otherHeaders-      otherHeaders =-        intercalateWith connRet (\x->"#include \""<>x<>"\"") $-          map unHdrName $-               map cihSelfHeader cihs-            ++ tihExtraHeadersInCPP tih--      allns = nubBy ((==) `on` unNamespace) ((tihClassDep tih >>= cihNamespace) ++ tihNamespaces tih)--      namespaceStr = do ns <- allns-                        ("using namespace " <> unNamespace ns <> ";\n")-      aliasStr = intercalate "\n" $-                   mapMaybe typedefstmt $-                     rights (concatMap cihImportedClasses cihs ++ extclasses)-        where typedefstmt c = let n1 = class_name c-                                  n2 = ffiClassName c-                              in if n1 == n2-                                 then Nothing-                                 else Just ("typedef " <> n1 <> " " <> n2 <> ";")-      declBodyStr    = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih)--  in subst definitionTemplate (context [ ("header"   , declHeaderStr)-                                       , ("namespace", namespaceStr )-                                       , ("alias"    , aliasStr     )-                                       , ("cppbody"  , declBodyStr  ) ])---- |-buildTemplateHeader :: TypeMacro  -- ^ typemacro prefix-                    -> TemplateClass-                    -> String-buildTemplateHeader (TypMcro typemacroprefix) t =-  let typemacrostr = typemacroprefix <> "TEMPLATE__" <> map toUpper (tclass_name t) <> "__"-      fs = tclass_funcs t-      deffunc = intercalateWith connRet (genTmplFunCpp False t) fs-                ++ "\n\n"-                ++ intercalateWith connRet (genTmplFunCpp True t) fs-      classlevel = genTmplClassCpp False t fs ++ "\n\n" ++ genTmplClassCpp True t fs-  in subst-       "#ifndef $typemacro\n\-       \#define $typemacro\n\-       \\n\-       \$deffunc\n\-       \$classlevel\n\-       \#endif\n"-       (context [ ("typemacro", typemacrostr )-                , ("deffunc"  , deffunc      )-                , ("classlevel" , classlevel )-                ])----- |-buildFFIHsc :: ClassModule -> Module ()-buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody-  where mname = cmModule m-        headers = cmCIH m-        ffiImports = [ mkImport "Data.Word"-                     , mkImport "Data.Int"-                     , mkImport "Foreign.C"-                     , mkImport "Foreign.Ptr"-                     , mkImport (mname <.> "RawType") ]-                     <> genImportInFFI m-                     <> genExtraImport m-        hscBody = concatMap genHsFFI headers----- |-buildRawTypeHs :: ClassModule -> Module ()-buildRawTypeHs m = mkModule (cmModule m <.> "RawType")-                  [lang [ "ForeignFunctionInterface", "TypeFamilies", "MultiParamTypeClasses"-                        , "FlexibleInstances", "TypeSynonymInstances"-                        , "EmptyDataDecls", "ExistentialQuantification", "ScopedTypeVariables" ]]-                  rawtypeImports rawtypeBody-  where rawtypeImports = [ mkImport "Foreign.Ptr"-                         , mkImport "FFICXX.Runtime.Cast"-                         ]-        rawtypeBody = concatMap hsClassRawType . filter (not.isAbstractClass) . cmClass $ m---- |-buildInterfaceHs :: AnnotateMap -> ClassModule -> Module ()-buildInterfaceHs amap m = mkModule (cmModule m <.> "Interface")-                            [lang [ "EmptyDataDecls", "ExistentialQuantification"-                                  , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface"-                                  , "MultiParamTypeClasses"-                                  , "ScopedTypeVariables"-                                  , "TypeFamilies", "TypeSynonymInstances"-                                  ]]-                            ifaceImports ifaceBody-  where classes = cmClass m-        ifaceImports = [ mkImport "Data.Word"-                       , mkImport "Data.Int"-                       , mkImport "Foreign.C"-                       , mkImport "Foreign.Ptr"-                       , mkImport "FFICXX.Runtime.Cast" ]-                       <> genImportInInterface m-                       <> genExtraImport m-        ifaceBody =-          runReader (mapM genHsFrontDecl classes) amap-          <> (concatMap genHsFrontUpcastClass . filter (not.isAbstractClass)) classes-          <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes---- |-buildCastHs :: ClassModule -> Module ()-buildCastHs m = mkModule (cmModule m <.> "Cast")-               [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies"-                      , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ]-               castImports body-  where classes = cmClass m-        castImports =    [ mkImport "Foreign.Ptr"-                         , mkImport "FFICXX.Runtime.Cast"-                         , mkImport "System.IO.Unsafe" ]-                      <> genImportInCast m-        body =    mapMaybe genHsFrontInstCastable classes-               <> mapMaybe genHsFrontInstCastableSelf classes---- |-buildImplementationHs :: AnnotateMap -> ClassModule -> Module ()-buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation")-                                 [ lang [ "EmptyDataDecls"-                                        , "FlexibleContexts"-                                        , "FlexibleInstances"-                                        , "ForeignFunctionInterface"-                                        , "IncoherentInstances"-                                        , "MultiParamTypeClasses"-                                        , "OverlappingInstances"-                                        , "TemplateHaskell"-                                        , "TypeFamilies"-                                        , "TypeSynonymInstances"-                                        ] ]-                                 implImports implBody-  where classes = cmClass m-        implImports = [ mkImport "Data.Monoid"                -- for template member-                      , mkImport "Data.Word"-                      , mkImport "Data.Int"-                      , mkImport "Foreign.C"-                      , mkImport "Foreign.Ptr"-                      , mkImport "Language.Haskell.TH"        -- for template member-                      , mkImport "Language.Haskell.TH.Syntax" -- for template member-                      , mkImport "System.IO.Unsafe"-                      , mkImport "FFICXX.Runtime.Cast"-                      , mkImport "FFICXX.Runtime.TH"          -- for template member-                      ]-                      <> genImportInImplementation m-                      <> genExtraImport m-        f :: Class -> [Decl ()]-        f y = concatMap (flip genHsFrontInst y) (y:class_allparents y)--        implBody =    concatMap f classes-                   <> runReader (concat <$> mapM genHsFrontInstNew classes) amap-                   <> concatMap genHsFrontInstNonVirtual classes-                   <> concatMap genHsFrontInstStatic classes-                   <> concatMap genHsFrontInstVariables classes-                   <> concatMap genTemplateMemberFunctions classes--buildTemplateHs :: TemplateClassModule -> Module ()-buildTemplateHs m = mkModule (tcmModule m <.> "Template")-                   [lang  [ "EmptyDataDecls", "FlexibleInstances", "MultiParamTypeClasses"-                          , "TypeFamilies"] ]-                   [ mkImport "Foreign.C.Types"-                   , mkImport "Foreign.Ptr"-                   , mkImport "FFICXX.Runtime.Cast"-                   ]-                   body-  where ts = tcmTemplateClasses m-        body = concatMap genTmplInterface ts--buildTHHs :: TemplateClassModule -> Module ()-buildTHHs m = mkModule (tcmModule m <.> "TH")-             [lang  ["TemplateHaskell"] ]-             ([ mkImport "Data.Char"-              , mkImport "Data.Monoid"-              , mkImport "Foreign.C.Types"-              , mkImport "Foreign.Ptr"-              , mkImport "Language.Haskell.TH"-              , mkImport "Language.Haskell.TH.Syntax"-              , mkImport "FFICXX.Runtime.TH"-              ] <> imports)-             body-  where ts = tcmTemplateClasses m-        imports = [ mkImport (tcmModule m <.> "Template") ]-        body = concatMap genTmplImplementation ts-               <> concatMap (\t -> genTmplInstance t (tclass_funcs t)) ts---- |-buildInterfaceHSBOOT :: String -> Module ()-buildInterfaceHSBOOT mname = mkModule (mname <.> "Interface") [] [] hsbootBody-  where cname = last (splitOn "." mname)-        hsbootBody = [ mkClass cxEmpty ('I':cname) [mkTBind "a"] [] ]---- |-buildModuleHs :: ClassModule -> Module ()-buildModuleHs m = mkModuleE (cmModule m) [] (concatMap genExport (cmClass m)) (genImportInModule (cmClass m)) []---- |-buildTopLevelHs :: String -> ([ClassModule],[TemplateClassModule]) -> TopLevelImportHeader -> Module ()-buildTopLevelHs modname (mods,tmods) tih =-    mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody-  where-    tfns = tihFuncs tih-    pkgExtensions = [ lang [ "FlexibleContexts", "FlexibleInstances" ] ]-    pkgExports =     map (emodule . cmModule) mods-                 ++  map (evar . unqual . hsFrontNameForTopLevelFunction) tfns--    pkgImports = genImportInTopLevel modname (mods,tmods) tih--    pkgBody    =    map (genTopLevelFuncFFI tih) tfns-                 ++ concatMap genTopLevelFuncDef tfns---- |-buildPackageInterface :: PackageInterface-                      -> PackageName-                      -> [ClassImportHeader]-                      -> PackageInterface-buildPackageInterface pinfc pkgname = foldr f pinfc-  where f cih repo =-          let name = (class_name . cihClass) cih-              header = cihSelfHeader cih-          in repo & at (pkgname,ClsName name) .~ (Just header)

@@ -1,430 +0,0 @@-{-# LANGUAGE RecordWildCards #-}--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Dependency--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Dependency where------- fficxx generates one module per one C++ class, and C++ class depends on other classes,--- so we need to import other modules corresponding to C++ classes in the dependency list.--- Calculating the import list from dependency graph is what this module does.---- Previously, we have only `Class` type, but added `TemplateClass` recently. Therefore--- we have to calculate dependency graph for both types of classes. So we needed to change--- `Class` to `Either TemplateClass Class` in many of routines that calculates module import--- list.---- `Dep4Func` contains a list of classes (both ordinary and template types) that is needed--- for the definition of a member function.--- The goal of `extractClassDep...` functions are to extract Dep4Func, and from the definition--- of a class or a template class, we get a list of `Dep4Func`s and then we deduplicate the--- dependency class list and finally get the import list for the module corresponding to--- a given class.-----import           Data.Either                (rights)-import           Data.Function              (on)-import qualified Data.HashMap.Strict as HM-import           Data.List-import qualified Data.Map            as M-import           Data.Maybe-import           Data.Monoid                ((<>))-import           System.FilePath----import           FFICXX.Generate.Name       (ffiClassName,hsClassName,hsTemplateClassName)-import           FFICXX.Generate.Type.Cabal (AddCInc,AddCSrc,CabalName(..)-                                            ,cabal_moduleprefix,cabal_pkgname-                                            ,cabal_cheaderprefix,unCabalName)-import           FFICXX.Generate.Type.Class-import           FFICXX.Generate.Type.Config (ModuleUnit(..)-                                             ,ModuleUnitImports(..),emptyModuleUnitImports-                                             ,ModuleUnitMap(..))-import           FFICXX.Generate.Type.Module-import           FFICXX.Generate.Type.PackageInterface----- utility functions--getcabal = either tclass_cabal class_cabal--getparents = either (const []) (map Right . class_parents)---- TODO: replace tclass_name with appropriate FFI name when supported.-getFFIName = either tclass_name ffiClassName---getPkgName :: Either TemplateClass Class -> CabalName-getPkgName = cabal_pkgname . getcabal----- |-extractClassFromType :: Types -> [Either TemplateClass Class]-extractClassFromType Void                     = []-extractClassFromType SelfType                 = []-extractClassFromType (CT _ _)                 = []-extractClassFromType (CPT (CPTClass c) _)     = [Right c]-extractClassFromType (CPT (CPTClassRef c) _)  = [Right c]-extractClassFromType (CPT (CPTClassCopy c) _) = [Right c]-extractClassFromType (CPT (CPTClassMove c) _) = [Right c]-extractClassFromType (TemplateApp (TemplateAppInfo t p _)) =-  (Left t): case p of-              TArg_Class c -> [Right c]-              _            -> []-extractClassFromType (TemplateAppRef (TemplateAppInfo t p _))   =-  (Left t): case p of-              TArg_Class c -> [Right c]-              _            -> []-extractClassFromType (TemplateAppMove (TemplateAppInfo t p _))   =-  (Left t): case p of-              TArg_Class c -> [Right c]-              _            -> []-extractClassFromType (TemplateType t)         = [Left t]-extractClassFromType (TemplateParam _)        = []-extractClassFromType (TemplateParamPointer _) = []---class_allparents :: Class -> [Class]-class_allparents c = let ps = class_parents c-                     in  if null ps-                           then []-                           else nub (ps <> (concatMap class_allparents ps))---getClassModuleBase :: Class -> String-getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName)--getTClassModuleBase :: TemplateClass -> String-getTClassModuleBase = (<.>) <$> (cabal_moduleprefix.tclass_cabal) <*> (fst.hsTemplateClassName)----- | Daughter map not including itself-mkDaughterMap :: [Class] -> DaughterMap-mkDaughterMap = foldl mkDaughterMapWorker M.empty-  where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)-                                  in  foldl (addmeToYourDaughterList c) m ps-        addmeToYourDaughterList c m p = let f Nothing = Just [c]-                                            f (Just cs)  = Just (c:cs)-                                        in  M.alter f p m------ | Daughter Map including itself as a daughter-mkDaughterSelfMap :: [Class] -> DaughterMap-mkDaughterSelfMap = foldl' worker M.empty-  where worker m c = let ps = map getClassModuleBase (c:class_allparents c)-                     in  foldl (addToList c) m ps-        addToList c m p = let f Nothing = Just [c]-                              f (Just cs)  = Just (c:cs)-                          in  M.alter f p m------ | class dependency for a given function-data Dep4Func = Dep4Func { returnDependency :: [Either TemplateClass Class]-                         , argumentDependency :: [Either TemplateClass Class] }----- |-extractClassDep :: Function -> Dep4Func-extractClassDep (Constructor args _)  =-    Dep4Func [] (concatMap (extractClassFromType.fst) args)-extractClassDep (Virtual ret _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)-extractClassDep (NonVirtual ret _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)-extractClassDep (Static ret _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)-extractClassDep (Destructor _) =-    Dep4Func [] []---extractClassDepForTmplFun :: TemplateFunction -> Dep4Func-extractClassDepForTmplFun (TFun ret  _ _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)-extractClassDepForTmplFun (TFunNew args _) =-    Dep4Func [] (concatMap (extractClassFromType.fst) args)-extractClassDepForTmplFun TFunDelete =-    Dep4Func [] []---extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func-extractClassDep4TmplMemberFun (TemplateMemberFunction {..}) =-  Dep4Func (extractClassFromType tmf_ret) (concatMap (extractClassFromType.fst) tmf_args)----extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func-extractClassDepForTopLevelFunction f =-    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)-  where ret = case f of-                TopLevelFunction {..} -> toplevelfunc_ret-                TopLevelVariable {..} -> toplevelvar_ret-        args = case f of-                 TopLevelFunction {..} -> toplevelfunc_args-                 TopLevelVariable {..} -> []----- TODO: Confirm the answer below is correct.--- NOTE: Q: Why returnDependency only?---       A: Difference between argument and return:---          for a member function f,---          we have (f :: (IA a, IB b) => a -> b -> IO C---          return class is concrete and argument class is constraint.-mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepRaw x@(Right c) =-  nub $-    filter (/= x) $-         concatMap (returnDependency . extractClassDep) (class_funcs c)-      ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)-mkModuleDepRaw x@(Left t) =-  (nub . filter (/= x) . concatMap (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t----isNotInSamePackageWith-  :: Either TemplateClass Class-  -> Either TemplateClass Class-  -> Bool-isNotInSamePackageWith x y = (x /= y) && (getPkgName x /= getPkgName y)---- x is in the sam-isInSamePackageButNotInheritedBy-  :: Either TemplateClass Class -- ^ y-  -> Either TemplateClass Class -- ^ x-  -> Bool-isInSamePackageButNotInheritedBy x y =-  x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y)----- TODO: Confirm the following answer--- NOTE: Q: why returnDependency is not considered?---       A: See explanation in mkModuleDepRaw-mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepHighNonSource y@(Right c) =-  let extclasses = filter (`isNotInSamePackageWith` y) $-                        concatMap (argumentDependency.extractClassDep) (class_funcs c)-                     ++ concatMap (argumentDependency.extractClassDep4TmplMemberFun) (class_tmpl_funcs c)-      parents = map Right (class_parents c)-  in  nub (parents <> extclasses)-mkModuleDepHighNonSource y@(Left t) =-  let fs = tclass_funcs t-      extclasses = filter (`isNotInSamePackageWith` y) $-                     concatMap (argumentDependency.extractClassDepForTmplFun) fs-  in  nub extclasses----- TODO: Confirm the following answer--- NOTE: Q: why returnDependency is not considered?---       A: See explanation in mkModuleDepRaw-mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepHighSource y@(Right c) =-  nub $-    filter (`isInSamePackageButNotInheritedBy` y) $-         concatMap (argumentDependency . extractClassDep) (class_funcs c)-      ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)-mkModuleDepHighSource y@(Left t) =-  let fs = tclass_funcs t-  in nub $-       filter (`isInSamePackageButNotInheritedBy` y) $-         concatMap (argumentDependency . extractClassDepForTmplFun) fs---- |-mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepCpp y@(Right c) =-  let fs = class_funcs c-      vs = class_vars c-      tmfs = class_tmpl_funcs c-  in  nub . filter (/= y)  $-           concatMap (returnDependency.extractClassDep) fs-        <> concatMap (argumentDependency.extractClassDep) fs-        <> concatMap (extractClassFromType . var_type) vs-        <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs-        <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs-        <> getparents y-mkModuleDepCpp y@(Left t) =-  let fs = tclass_funcs t-  in  nub . filter (/= y)  $-           concatMap (returnDependency.extractClassDepForTmplFun) fs-        <> concatMap (argumentDependency.extractClassDepForTmplFun) fs-        <> getparents y---- |-mkModuleDepFFI1 :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepFFI1 (Right c) = let fs = class_funcs c-                                vs = class_vars c-                                tmfs = class_tmpl_funcs c-                            in    concatMap (returnDependency.extractClassDep) fs-                               <> concatMap (argumentDependency.extractClassDep) fs-                               <> concatMap (extractClassFromType . var_type) vs-                               <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs-                               <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs-mkModuleDepFFI1 (Left t)  = let fs = tclass_funcs t-                            in    concatMap (returnDependency.extractClassDepForTmplFun) fs-                               <> concatMap (argumentDependency.extractClassDepForTmplFun) fs---- |-mkModuleDepFFI :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepFFI y@(Right c) =-  let ps = map Right (class_allparents c)-      alldeps' = (concatMap mkModuleDepFFI1 ps) <> mkModuleDepFFI1 y-  in nub (filter (/= y) alldeps')-mkModuleDepFFI (Left _) = []---mkClassModule :: (ModuleUnit -> ModuleUnitImports)-              -> [(String,[String])]-              -> Class-              -> ClassModule-mkClassModule getImports extra c =-    ClassModule {-      cmModule = getClassModuleBase c-    , cmClass = [c]-    , cmCIH = map (mkCIH getImports) [c]-    , cmImportedModulesHighNonSource = highs_nonsource-    , cmImportedModulesRaw =raws-    , cmImportedModulesHighSource = highs_source-    , cmImportedModulesForFFI = ffis-    , cmExtraImport = extraimports-    }-  where highs_nonsource = mkModuleDepHighNonSource (Right c)-        raws            = mkModuleDepRaw (Right c)-        highs_source    = mkModuleDepHighSource (Right c)-        ffis            = mkModuleDepFFI (Right c)-        extraimports = fromMaybe [] (lookup (class_name c) extra)---findModuleUnitImports :: ModuleUnitMap -> ModuleUnit -> ModuleUnitImports-findModuleUnitImports m u =-  fromMaybe emptyModuleUnitImports (HM.lookup u (unModuleUnitMap m))---mkTCM :: (TemplateClass,HeaderName) -> TemplateClassModule-mkTCM (t,hdr) = TCM  (getTClassModuleBase t) [t] [TCIH t hdr]---mkPackageConfig-  :: (CabalName, ModuleUnit -> ModuleUnitImports) -- ^ (package name,getImports)-  -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])])-  -> [AddCInc]-  -> [AddCSrc]-  -> PackageConfig-mkPackageConfig (pkgname,getImports) (cs,fs,ts,extra) acincs acsrcs =-  let ms = map (mkClassModule getImports extra) cs-      cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)-      cihs = nubBy cmpfunc (concatMap cmCIH ms)-      ---      tih = mkTIH pkgname getImports cihs fs-      tcms = map mkTCM ts-      tcihs = concatMap tcmTCIH tcms-  in PkgConfig {-       pcfg_classModules = ms-     , pcfg_classImportHeaders = cihs-     , pcfg_topLevelImportHeader = tih-     , pcfg_templateClassModules = tcms-     , pcfg_templateClassImportHeaders = tcihs-     , pcfg_additional_c_incs = acincs-     , pcfg_additional_c_srcs = acsrcs-     }----- TODO: change [String] to Set String-mkHSBOOTCandidateList :: [ClassModule] -> [String]-mkHSBOOTCandidateList ms =-  let-    -- get only class dependencies, not template classes.-    cs = rights (concatMap cmImportedModulesHighSource ms)-  in-    nub (map getClassModuleBase cs)------ |-mkPkgHeaderFileName ::Class -> HeaderName-mkPkgHeaderFileName c =-    HdrName (   (cabal_cheaderprefix.class_cabal) c-            <>  fst (hsClassName c)-            <.> "h"-            )---- |-mkPkgCppFileName ::Class -> String-mkPkgCppFileName c =-        (cabal_cheaderprefix.class_cabal) c-    <>  fst (hsClassName c)-    <.> "cpp"---- |-mkPkgIncludeHeadersInH :: Class -> [HeaderName]-mkPkgIncludeHeadersInH c =-    let pkgname = (cabal_pkgname . class_cabal) c-        extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c-        extheaders = nub . map ((<>"Type.h") . unCabalName . getPkgName) $ extclasses-    in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders------ |-mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]-mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right----- |-mkCIH :: (ModuleUnit -> ModuleUnitImports)  -- ^ (mk namespace and include headers)-      -> Class-      -> ClassImportHeader-mkCIH getImports c =-  ClassImportHeader {-    cihClass                    = c-  , cihSelfHeader               = mkPkgHeaderFileName c-  , cihNamespace                = (muimports_namespaces . getImports . MU_Class . class_name) c-  , cihSelfCpp                  = mkPkgCppFileName c-  , cihImportedClasses          = mkModuleDepCpp (Right c)-  , cihIncludedHPkgHeadersInH   = mkPkgIncludeHeadersInH c-  , cihIncludedHPkgHeadersInCPP = mkPkgIncludeHeadersInCPP c-  , cihIncludedCPkgHeaders      = (muimports_headers . getImports . MU_Class . class_name) c-  }---- | for top-level-mkTIH-  :: CabalName-  -> (ModuleUnit -> ModuleUnitImports)-  -> [ClassImportHeader]-  -> [TopLevelFunction]-  -> TopLevelImportHeader-mkTIH pkgname getImports cihs fs =-  let tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs-      tl_cs2 = concatMap (returnDependency . extractClassDepForTopLevelFunction) fs-      tl_cs = nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2)-      -- NOTE: Select only class dependencies in the current package.-      -- TODO: This is clearly not a good impl. we need to look into this again-      --       after reconsidering multi-package generation.-      tl_cihs = catMaybes (foldr fn [] tl_cs)-         where-           fn c ys =-             let y = find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs-             in y:ys-      -- NOTE: The remaining class dependencies outside the current package-      extclasses = filter ((/= pkgname) . getPkgName) tl_cs-      extheaders = map HdrName $-                     nub $-                       map ((<>"Type.h") . unCabalName . getPkgName)  extclasses--  in-     TopLevelImportHeader {-       tihHeaderFileName = unCabalName pkgname <> "TopLevel"-     , tihClassDep = tl_cihs-     , tihExtraClassDep = extclasses-     , tihFuncs = fs-     , tihNamespaces        = muimports_namespaces (getImports MU_TopLevel)-     , tihExtraHeadersInH   = extheaders-     , tihExtraHeadersInCPP = muimports_headers (getImports MU_TopLevel)-     }

@@ -1,140 +0,0 @@-{-# LANGUAGE RecordWildCards #-}-module FFICXX.Generate.Name where--import           Data.Char                         (toLower)-import           Data.Maybe                        (fromMaybe,maybe)-import           Data.Monoid                       ((<>))----import           FFICXX.Generate.Type.Class-import           FFICXX.Generate.Util----hsFrontNameForTopLevelFunction :: TopLevelFunction -> String-hsFrontNameForTopLevelFunction tfn =-    let (x:xs) = case tfn of-                   TopLevelFunction {..} -> fromMaybe toplevelfunc_name toplevelfunc_alias-                   TopLevelVariable {..} -> fromMaybe toplevelvar_name  toplevelvar_alias-    in toLower x : xs---typeclassName :: Class -> String-typeclassName c = 'I' : fst (hsClassName c)--typeclassNameT :: TemplateClass -> String-typeclassNameT c = 'I' : fst (hsTemplateClassName c)----typeclassNameFromStr :: String -> String-typeclassNameFromStr = ('I':)--hsClassName :: Class -> (String, String)  -- ^ High-level, 'Raw'-level-hsClassName c =-  let cname = maybe (class_name c) caHaskellName (class_alias c)-  in (cname, "Raw" <> cname)--hsClassNameForTArg :: TemplateArgType -> String-hsClassNameForTArg (TArg_Class c) = fst (hsClassName c)-hsClassNameForTArg (TArg_TypeParam p) = p-hsClassNameForTArg (TArg_Other s) = s--hsTemplateClassName :: TemplateClass -> (String, String)  -- ^ High-level, 'Raw'-level-hsTemplateClassName t =-  let tname = tclass_name t-  in (tname, "Raw" <> tname)--existConstructorName :: Class -> String-existConstructorName c = 'E' : (fst.hsClassName) c---ffiClassName :: Class -> String-ffiClassName c = maybe (class_name c) caFFIName (class_alias c)--hscFuncName :: Class -> Function -> String-hscFuncName c f =    "c_"-                  <> toLowers (ffiClassName c)-                  <> "_"-                  <> toLowers (aliasedFuncName c f)--hsFuncName :: Class -> Function -> String-hsFuncName c f = let (x:xs) = aliasedFuncName c f-                 in (toLower x) : xs--aliasedFuncName :: Class -> Function -> String-aliasedFuncName c f =-  case f of-    Constructor _ a      -> fromMaybe (constructorName c) a-    Virtual _ str _ a    -> fromMaybe str a-    NonVirtual _ str _ a -> fromMaybe (nonvirtualName c str) a-    Static _ str _ a     -> fromMaybe (nonvirtualName c str) a-    Destructor a         -> fromMaybe destructorName a---hsTmplFuncName :: TemplateClass -> TemplateFunction -> String-hsTmplFuncName t f =-  case f of-    TFun {..}    -> tfun_name  -- TODO: alias-    TFunNew {..} -> fromMaybe ("new"<> tclass_name t) tfun_new_alias-    TFunDelete   -> "delete" <> tclass_name t---hsTmplFuncNameTH :: TemplateClass -> TemplateFunction -> String-hsTmplFuncNameTH t f = "t_" <> hsTmplFuncName t f---hsTemplateMemberFunctionName :: Class -> TemplateMemberFunction -> String-hsTemplateMemberFunctionName c f = fromMaybe (nonvirtualName c (tmf_name f)) (tmf_alias f)-  --   fst (hsClassName c) <> "_" <> tmf_name f -- TODO: alias---hsTemplateMemberFunctionNameTH :: Class -> TemplateMemberFunction -> String-hsTemplateMemberFunctionNameTH c f = "t_" <> hsTemplateMemberFunctionName c f---ffiTmplFuncName :: TemplateFunction -> String-ffiTmplFuncName f =-  case f of-    TFun {..}    -> fromMaybe tfun_name tfun_alias-    TFunNew {..} -> fromMaybe "new" tfun_new_alias-    TFunDelete   -> "delete"---cppTmplFuncName :: TemplateFunction -> String-cppTmplFuncName f =-  case f of-    TFun {..}    -> tfun_name-    TFunNew {..} -> "new"-    TFunDelete   -> "delete"--accessorName :: Class -> Variable -> Accessor -> String-accessorName c v a =    nonvirtualName c (var_name v)-                     <> "_"-                     <> case a of-                          Getter -> "get"-                          Setter -> "set"--hscAccessorName :: Class -> Variable -> Accessor -> String-hscAccessorName c v a = "c_" <> toLowers (accessorName c v a)---cppStaticName :: Class -> Function -> String-cppStaticName c f = class_name c <> "::" <> func_name f--cppFuncName :: Class -> Function -> String-cppFuncName c f =   case f of-    Constructor _ _ -> "new"-    Virtual _ _  _ _ -> func_name f-    NonVirtual _ _ _ _-> func_name f-    Static _ _ _ _-> cppStaticName c f-    Destructor _ -> destructorName--constructorName :: Class -> String-constructorName c = "new" <> (fst.hsClassName) c--nonvirtualName :: Class -> String -> String-nonvirtualName c str = (firstLower.fst.hsClassName) c <> "_" <> str--destructorName :: String-destructorName = "delete"-

@@ -1,25 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.QQ.Verbatim--- Copyright   : (c) 2011-2013 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.QQ.Verbatim where--import Language.Haskell.TH.Quote-import Language.Haskell.TH.Lib--verbatim :: QuasiQuoter-verbatim = QuasiQuoter{ quoteExp = litE . stringL-                      , quotePat = undefined-                      , quoteType = undefined-                      , quoteDec = undefined-                      --           , quotePat = litP . stringP-                      } -

@@ -1,23 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Type.Annotate--- Copyright   : (c) 2011-2013 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Type.Annotate where--import qualified Data.Map as M--data PkgType = PkgModule | PkgClass | PkgMethod -               deriving (Show,Eq,Ord)--type AnnotateMap = M.Map (PkgType,String) String---

@@ -1,88 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Type.Cabal--- Copyright   : (c) 2011-2019 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Type.Cabal where--import Data.Aeson       (FromJSON(..),ToJSON(..)-                        ,genericParseJSON,genericToJSON-                        ,defaultOptions)-import Data.Aeson.Types (fieldLabelModifier)-import Data.Text        (Text)-import GHC.Generics     (Generic)--data AddCInc = AddCInc FilePath String--data AddCSrc = AddCSrc FilePath String---- TODO: change String to Text-newtype CabalName = CabalName { unCabalName :: String }-                  deriving (Show,Eq,Ord)---data BuildType = Simple-               | Custom [CabalName] -- ^ dependencies---- TODO: change String to Text-data Cabal =-       Cabal {-         cabal_pkgname            :: CabalName-       , cabal_version            :: String-       , cabal_cheaderprefix      :: String-       , cabal_moduleprefix       :: String-       , cabal_additional_c_incs  :: [AddCInc]-       , cabal_additional_c_srcs  :: [AddCSrc]-       , cabal_additional_pkgdeps :: [CabalName]-       , cabal_license            :: Maybe String-       , cabal_licensefile        :: Maybe String-       , cabal_extraincludedirs   :: [FilePath]-       , cabal_extralibdirs       :: [FilePath]-       , cabal_extrafiles         :: [FilePath]-       , cabal_pkg_config_depends :: [String]-       , cabal_buildType          :: BuildType-       }--data GeneratedCabalInfo =-       GeneratedCabalInfo {-         gci_pkgname          :: Text-       , gci_version          :: Text-       , gci_synopsis         :: Text-       , gci_description      :: Text-       , gci_homepage         :: Text-       , gci_license          :: Text-       , gci_licenseFile      :: Text-       , gci_author           :: Text-       , gci_maintainer       :: Text-       , gci_category         :: Text-       , gci_buildtype        :: Text-       , gci_extraFiles       :: [Text]-       , gci_csrcFiles        :: [Text]-       , gci_sourcerepository :: Text-       , gci_cxxOptions       :: [Text]-       , gci_pkgdeps          :: [Text]-       , gci_exposedModules   :: [Text]-       , gci_otherModules     :: [Text]-       , gci_extraLibDirs     :: [Text]-       , gci_extraLibraries   :: [Text]-       , gci_extraIncludeDirs :: [Text]-       , gci_pkgconfigDepends :: [Text]-       , gci_includeFiles     :: [Text]-       , gci_cppFiles         :: [Text]-       }-  deriving (Show,Generic)--instance ToJSON GeneratedCabalInfo where-  toJSON = genericToJSON defaultOptions {fieldLabelModifier = drop 4}--instance FromJSON GeneratedCabalInfo where-  parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = drop 4}

@@ -1,295 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE RecordWildCards #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Type.Class--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Type.Class where-import qualified Data.Map                     as M-import           Data.Monoid                       (Monoid(..))-import           Data.Semigroup                    (Semigroup(..),(<>))----import           FFICXX.Generate.Type.Cabal----- | C types-data CTypes = CTBool-            | CTChar-            | CTClock-            | CTDouble-            | CTFile-            | CTFloat-            | CTFpos-            | CTInt-            | CTIntMax-            | CTIntPtr-            | CTJmpBuf-            | CTLLong-            | CTLong-            | CTPtrdiff-            | CTSChar-            | CTSUSeconds-            | CTShort-            | CTSigAtomic-            | CTSize-            | CTTime-            | CTUChar-            | CTUInt-            | CTUIntMax-            | CTUIntPtr-            | CTULLong-            | CTULong-            | CTUSeconds-            | CTUShort-            | CTWchar-            | CTInt8-            | CTInt16-            | CTInt32-            | CTInt64-            | CTUInt8-            | CTUInt16-            | CTUInt32-            | CTUInt64-            | CTVoidStar-            | CTString-            | CEnum CTypes String-            | CPointer CTypes-            | CRef CTypes-            deriving Show---- | C++ types-data CPPTypes = CPTClass Class-              | CPTClassRef Class-              | CPTClassCopy Class-              | CPTClassMove Class-              deriving Show---- | const flag-data IsConst = Const | NoConst-             deriving Show---- | Argument type which can be used as an template argument like float---   in vector<float>.---   For now, this distinguishes Class and non-Class.-data TemplateArgType = TArg_Class Class-                     | TArg_TypeParam String-                     | TArg_Other String-                     deriving Show--data TemplateAppInfo = TemplateAppInfo {-                         tapp_tclass :: TemplateClass-                       , tapp_tparam :: TemplateArgType-                       , tapp_CppTypeForParam :: String-                       }-                     deriving Show--data Types = Void-           | SelfType-           | CT  CTypes IsConst-           | CPT CPPTypes IsConst-           | TemplateApp     TemplateAppInfo  -- ^ like vector<float>*-           | TemplateAppRef  TemplateAppInfo  -- ^ like vector<float>&-           | TemplateAppMove TemplateAppInfo  -- ^ like unique_ptr<float> (using std::move)-           | TemplateType    TemplateClass    -- ^ template self? TODO: clarify this.-           | TemplateParam   String-           | TemplateParamPointer String      -- ^ this is A* with template<A>-           deriving Show-----------------type Args = [(Types,String)]--data Function = Constructor { func_args :: Args-                            , func_alias :: Maybe String-                            }-              | Virtual { func_ret :: Types-                        , func_name :: String-                        , func_args :: Args-                        , func_alias :: Maybe String-                        }-              | NonVirtual { func_ret :: Types-                           , func_name :: String-                           , func_args :: Args-                           , func_alias :: Maybe String-                           }-              | Static     { func_ret :: Types-                           , func_name :: String-                           , func_args :: Args-                           , func_alias :: Maybe String-                           }-              | Destructor  { func_alias :: Maybe String }-              deriving Show---data Variable = Variable { var_type :: Types-                         , var_name :: String-                         }-              deriving Show--data TemplateMemberFunction =-       TemplateMemberFunction {-         tmf_param :: String-       , tmf_ret :: Types-       , tmf_name :: String-       , tmf_args :: Args-       , tmf_alias :: Maybe String-       }-       deriving Show---data TopLevelFunction = TopLevelFunction { toplevelfunc_ret :: Types-                                         , toplevelfunc_name :: String-                                         , toplevelfunc_args :: Args-                                         , toplevelfunc_alias :: Maybe String-                                         }-                      | TopLevelVariable { toplevelvar_ret :: Types-                                         , toplevelvar_name :: String-                                         , toplevelvar_alias :: Maybe String }-                      deriving Show-----isNewFunc :: Function -> Bool-isNewFunc (Constructor _ _) = True-isNewFunc _ = False--isDeleteFunc :: Function -> Bool-isDeleteFunc (Destructor _) = True-isDeleteFunc _ = False--isVirtualFunc :: Function -> Bool-isVirtualFunc (Destructor _)          = True-isVirtualFunc (Virtual _ _ _ _)       = True-isVirtualFunc _                       = False--isNonVirtualFunc :: Function -> Bool-isNonVirtualFunc (NonVirtual _ _ _ _) = True-isNonVirtualFunc _                    = False----isStaticFunc :: Function -> Bool-isStaticFunc (Static _ _ _ _) = True-isStaticFunc _ = False--virtualFuncs :: [Function] -> [Function]-virtualFuncs = filter isVirtualFunc--constructorFuncs :: [Function] -> [Function]-constructorFuncs = filter isNewFunc--nonVirtualNotNewFuncs :: [Function] -> [Function]-nonVirtualNotNewFuncs =-  filter (\x -> (not.isVirtualFunc) x && (not.isNewFunc) x && (not.isDeleteFunc) x && (not.isStaticFunc) x )--staticFuncs :: [Function] -> [Function]-staticFuncs = filter isStaticFunc------------newtype ProtectedMethod = Protected { unProtected :: [String] }-                        deriving (Semigroup, Monoid)--data ClassAlias = ClassAlias { caHaskellName :: String-                             , caFFIName :: String-                             }---- TODO: partial record must be avoided.-data Class = Class {-               class_cabal :: Cabal-             , class_name :: String-             , class_parents :: [Class]-             , class_protected :: ProtectedMethod-             , class_alias :: Maybe ClassAlias-             , class_funcs :: [Function]-             , class_vars :: [Variable]-             , class_tmpl_funcs :: [TemplateMemberFunction]-             }-           | AbstractClass {-               class_cabal :: Cabal-             , class_name :: String-             , class_parents :: [Class]-             , class_protected :: ProtectedMethod-             , class_alias :: Maybe ClassAlias-             , class_funcs :: [Function]-             , class_vars :: [Variable]-             , class_tmpl_funcs :: [TemplateMemberFunction]-             }---- TODO: we had better not override standard definitions-instance Show Class where-  show x = show (class_name x)---- TODO: we had better not override standard definitions-instance Eq Class where-  (==) x y = class_name x == class_name y---- TODO: we had better not override standard definitions-instance Ord Class where-  compare x y = compare (class_name x) (class_name y)---data TemplateFunction = TFun { tfun_ret :: Types-                             , tfun_name :: String-                             , tfun_oname :: String-                             , tfun_args :: Args-                             , tfun_alias :: Maybe String }-                      | TFunNew { tfun_new_args :: Args-                                , tfun_new_alias :: Maybe String-                                }-                      | TFunDelete---data TemplateClass = TmplCls { tclass_cabal :: Cabal-                             , tclass_name :: String-                             , tclass_oname :: String-                             , tclass_param :: String-                             , tclass_funcs :: [TemplateFunction]-                             }---- TODO: we had better not override standard definitions-instance Show TemplateClass where-  show x = show (tclass_name x <> " " <> tclass_param x)---- TODO: we had better not override standard definitions-instance Eq TemplateClass where-  (==) x y = tclass_name x == tclass_name y---- TODO: we had better not override standard definitions-instance Ord TemplateClass where-  compare x y = compare (tclass_name x) (tclass_name y)---data ClassGlobal = ClassGlobal-                   { cgDaughterSelfMap :: DaughterMap-                   , cgDaughterMap :: DaughterMap-                   }--data Selfness = Self | NoSelf------ | Check abstract class--isAbstractClass :: Class -> Bool-isAbstractClass Class{}         = False-isAbstractClass AbstractClass{} = True----type DaughterMap = M.Map String [Class]--data Accessor = Getter | Setter-              deriving (Show, Eq)

@@ -1,25 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-module FFICXX.Generate.Type.Config where--import Data.Hashable (Hashable(..))-import Data.HashMap.Strict (HashMap)-import GHC.Generics (Generic)----import FFICXX.Generate.Type.PackageInterface (HeaderName(..),Namespace(..))--data ModuleUnit = MU_TopLevel -                | MU_Class String-                deriving (Show,Eq,Generic)--instance Hashable ModuleUnit--data ModuleUnitImports =-  ModuleUnitImports {-    muimports_namespaces :: [Namespace]-  , muimports_headers    :: [HeaderName]-  }-  deriving (Show)--emptyModuleUnitImports = ModuleUnitImports [] []--newtype ModuleUnitMap = ModuleUnitMap { unModuleUnitMap :: HashMap ModuleUnit ModuleUnitImports }

@@ -1,76 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Type.Module--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Type.Module where--import FFICXX.Generate.Type.Cabal (AddCInc,AddCSrc)-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.PackageInterface (HeaderName(..),Namespace(..))---- | C++ side---   HPkg is generated C++ headers by fficxx, CPkg is original C++ headers-data ClassImportHeader = ClassImportHeader-                       { cihClass :: Class-                       , cihSelfHeader :: HeaderName-                       , cihNamespace :: [Namespace]-                       , cihSelfCpp :: String-                       , cihImportedClasses :: [Either TemplateClass Class]  -- ^ Dependencies TODO: clarify this.-                       , cihIncludedHPkgHeadersInH   :: [HeaderName]         -- TODO: Explain why we need to have these two-                       , cihIncludedHPkgHeadersInCPP :: [HeaderName]         --       separately.-                       , cihIncludedCPkgHeaders      :: [HeaderName]-                       } deriving (Show)----- | Haskell side-data ClassModule = ClassModule-                   { cmModule :: String-                   , cmClass :: [Class]-                   , cmCIH :: [ClassImportHeader]-                   , cmImportedModulesHighNonSource :: [Either TemplateClass Class]  -- ^ imported modules that do not need source-                                                                         -- NOTE: source means the same cabal package.-                                                                         -- TODO: rename Source to something more clear.-                   , cmImportedModulesRaw           :: [Either TemplateClass Class]  -- ^ imported modules for raw types.-                   , cmImportedModulesHighSource    :: [Either TemplateClass Class]  -- ^ imported modules that need source-                   , cmImportedModulesForFFI        :: [Either TemplateClass Class]-                   , cmExtraImport :: [String]-                   } deriving (Show)--data TemplateClassModule = TCM { tcmModule :: String-                               , tcmTemplateClasses :: [TemplateClass]-                               , tcmTCIH :: [TemplateClassImportHeader]-                               } deriving (Show)---data TemplateClassImportHeader = TCIH { tcihTClass :: TemplateClass-                                      , tcihSelfHeader :: HeaderName-                                      } deriving (Show)--data TopLevelImportHeader = TopLevelImportHeader {-                              tihHeaderFileName    :: String-                            , tihClassDep          :: [ClassImportHeader]-                            , tihExtraClassDep     :: [Either TemplateClass Class]-                              -- ^ Extra class dependencies outside current package.-                              --   NOTE: we cannot fully construct ClassImportHeader for them.-                            , tihFuncs             :: [TopLevelFunction]-                            , tihNamespaces        :: [Namespace]-                            , tihExtraHeadersInH   :: [HeaderName]-                            , tihExtraHeadersInCPP :: [HeaderName]-                            } deriving (Show)--data PackageConfig = PkgConfig { pcfg_classModules :: [ClassModule]-                               , pcfg_classImportHeaders :: [ClassImportHeader]-                               , pcfg_topLevelImportHeader :: TopLevelImportHeader-                               , pcfg_templateClassModules :: [TemplateClassModule]-                               , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader]-                               , pcfg_additional_c_incs :: [AddCInc]-                               , pcfg_additional_c_srcs :: [AddCSrc]-                               }

@@ -1,36 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Type.PackageInterface--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Type.PackageInterface where --import           Data.Hashable-import qualified Data.HashMap.Strict as HM-import           Data.String--newtype PackageName = PkgName String  deriving (Hashable, Show, Eq, Ord)-newtype ClassName = ClsName String deriving (Hashable, Show, Eq, Ord)--newtype HeaderName = HdrName { unHdrName :: String }-                   deriving (Hashable, Show, Eq, Ord)---instance IsString HeaderName where-  fromString = HdrName--newtype Namespace = NS { unNamespace :: String } deriving (Show)--type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName --newtype TypeMacro = TypMcro { unTypMcro :: String } -                  deriving (Show,Eq,Ord)

@@ -1,99 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Util--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC------------------------------------------------------------------------------------module FFICXX.Generate.Util where--import           Data.Char -import           Data.List-import           Data.List.Split-import           Data.Maybe               (fromMaybe)-import           Data.Monoid              ((<>))-import           Data.Text                (Text)-import qualified Data.Text          as T-import qualified Data.Text.Lazy     as TL-import           Data.Text.Template---moduleDirFile :: String -> (String,String)-moduleDirFile mname = -  let splitted = splitOn "." mname-      moddir  = intercalate "/" (init splitted )-      modfile = (last splitted) <> ".hs" -  in  (moddir, modfile)--hline :: IO ()-hline = putStrLn "--------------------------------------------------------"--toUppers :: String -> String-toUppers = map toUpper--toLowers :: String -> String -toLowers = map toLower---firstLower :: String -> String -firstLower [] = [] -firstLower (x:xs) = (toLower x) : xs --conn :: String -> String -> String -> String -conn st x y = x <> st <> y  --connspace :: String -> String -> String-connspace = conn " " --conncomma :: String -> String -> String-conncomma =  conn ", " --connBSlash :: String -> String -> String -connBSlash = conn "\\\n"--connSemicolonBSlash :: String -> String -> String-connSemicolonBSlash = conn "; \\\n"--connRet :: String -> String -> String-connRet = conn "\n"--connRet2 :: String -> String -> String -connRet2 = conn "\n\n"--connArrow :: String -> String -> String -connArrow = conn " -> " --intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String-intercalateWith  f mapper x -  | not (null x) = foldl1 f (map mapper x)-  | otherwise    = "" ---intercalateWithM :: (Monad m) => (String -> String -> String) -> (a->m String) -> [a] -> m String -intercalateWithM f mapper x -  | not (null x) = do ms <- mapM mapper x-                      return (foldl1 f ms)-  | otherwise = return "" ----- TODO: deprecate this and use contextT-context :: [(Text,String)] -> Context-context assocs x = maybe err (T.pack) . lookup x $ assocs-  where err = error $ "Could not find key: " <> (T.unpack x)---- TODO: Rename this to context.--- TODO: Proper error handling.-contextT :: [(Text,Text)] -> Context-contextT assocs x = fromMaybe err . lookup x $ assocs-  where err = error $ T.unpack ("Could not find key: " <> x)--subst :: Text -> Context -> String-subst t c = TL.unpack (substitute t c)-

@@ -1,213 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Util.HaskellSrcExts--- Copyright   : (c) 2011-2018 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC------------------------------------------------------------------------------------module FFICXX.Generate.Util.HaskellSrcExts where--import           Data.Maybe                          (maybeToList)-import           Data.List                           (foldl')-import           Language.Haskell.Exts        hiding (unit_tycon)-import qualified Language.Haskell.Exts               (unit_tycon)---unqual :: String  -> QName ()-unqual = UnQual () . Ident ()--tycon :: String -> Type ()-tycon = TyCon () . unqual--tyapp :: Type () -> Type () -> Type ()-tyapp = TyApp ()--tyfun :: Type () -> Type () -> Type ()-tyfun = TyFun ()--tylist :: Type () -> Type ()-tylist = TyList ()--unit_tycon :: Type ()-unit_tycon = Language.Haskell.Exts.unit_tycon ()--conDecl :: String -> [Type ()] -> ConDecl ()-conDecl n ys = ConDecl () (Ident () n) ys--qualConDecl = QualConDecl ()--recDecl :: String -> [FieldDecl ()] -> ConDecl ()-recDecl n rs = RecDecl () (Ident () n) rs--app' :: String -> String -> Exp ()-app' x y = App () (mkVar x) (mkVar y)---lit :: Literal () -> Exp ()-lit = Lit ()---mkVar :: String -> Exp ()-mkVar = Var () . unqual--con :: String -> Exp ()-con = Con () . unqual--mkTVar :: String -> Type ()-mkTVar = TyVar () . Ident ()--mkPVar :: String -> Pat ()-mkPVar = PVar () . Ident ()--mkIVar :: String -> ImportSpec ()-mkIVar = IVar () . Ident ()--mkPVarSig :: String -> Type () -> Pat ()-mkPVarSig n typ = PatTypeSig () (mkPVar n) typ--pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl ()-pbind pat e = PatBind () pat (UnGuardedRhs () e)--mkTBind :: String -> TyVarBind ()-mkTBind = UnkindedVar () . Ident ()--mkBind1 :: String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()-mkBind1 n pat rhs mbinds =-  FunBind () [ Match () (Ident () n) pat (UnGuardedRhs () rhs) mbinds ]--mkFun :: String -> Type () -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> [Decl ()]-mkFun fname typ pats rhs mbinds = [mkFunSig fname typ, mkBind1 fname pats rhs mbinds]--mkFunSig :: String -> Type () -> Decl ()-mkFunSig fname typ = TypeSig () [Ident () fname] typ--mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()-mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds)  [] (Just cdecls)---dhead :: String -> DeclHead ()-dhead n = DHead () (Ident () n)--mkDeclHead :: String -> [TyVarBind ()] -> DeclHead ()-mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds--mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()-mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls)-  where instrule = IRule () Nothing (Just ctxt) insthead-        insthead  = foldl' f (IHCon () (unqual n)) typs-          where f acc x = IHApp () acc (tyParen x)--mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()-#if MIN_VERSION_haskell_src_exts(1,20,0)-mkData n tbinds qdecls mderiv  = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv)-#else-mkData n tbinds qdecls mderiv  = DataDecl () (DataType ()) Nothing declhead qdecls mderiv-#endif-  where declhead = mkDeclHead n tbinds--mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()-#if MIN_VERSION_haskell_src_exts(1,20,0)-mkNewtype n tbinds qdecls mderiv  = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv)-#else-mkNewtype n tbinds qdecls mderiv  = DataDecl () (NewType ()) Nothing declhead qdecls mderiv-#endif-  where declhead = mkDeclHead n tbinds--mkForImpCcall :: String -> String -> Type () -> Decl ()-mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlaySafe () False)) (Just quote) (Ident () n) typ--mkModule :: String -> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()-mkModule n pragmas idecls decls = Module () (Just mhead) pragmas idecls decls-  where mhead = ModuleHead () (ModuleName () n) Nothing Nothing--mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()-mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas  idecls decls-  where mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist)-        eslist = ExportSpecList () exps--mkImport :: String -> ImportDecl ()-mkImport m = ImportDecl () (ModuleName () m) False False False Nothing Nothing Nothing--mkImportExp :: String -> [String] -> ImportDecl ()-mkImportExp m lst =-  ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist)-  where islist = ImportSpecList () False (map mkIVar lst)---mkImportSrc :: String -> ImportDecl ()-mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing--lang :: [String] -> ModulePragma ()-lang ns = LanguagePragma () (map (Ident ()) ns)--dot :: Exp () -> Exp () -> Exp ()-x `dot` y = x `app` mkVar "." `app` y--tyForall = TyForall ()--tyParen = TyParen ()--tyPtr :: Type ()-tyPtr = tycon "Ptr"--tyForeignPtr :: Type ()-tyForeignPtr = tycon "ForeignPtr"--classA :: QName () -> [Type ()] -> Asst ()-classA = ClassA ()--cxEmpty :: Context ()-cxEmpty = CxEmpty ()--cxTuple :: [Asst ()] -> Context ()-cxTuple = CxTuple ()--tySplice :: Splice () -> Type ()-tySplice = TySplice ()--parenSplice :: Exp () -> Splice ()-parenSplice = ParenSplice ()--bracketExp = BracketExp ()-typeBracket = TypeBracket ()---#if MIN_VERSION_haskell_src_exts(1,20,0)-mkDeriving = Deriving () Nothing-#else-mkDeriving = Deriving ()-#endif--irule = IRule ()--ihcon = IHCon ()--evar = EVar ()-eabs = EAbs ()-ethingwith = EThingWith ()--ethingall q = ethingwith (EWildcard () 0) q []--emodule nm = EModuleContents () (ModuleName () nm)--nonamespace = NoNamespace ()--list = List ()-lambda = Lambda ()--insType = InsType ()-insDecl = InsDecl ()--generator = Generator ()--clsDecl = ClsDecl ()---unkindedVar = UnkindedVar ()

@@ -0,0 +1,264 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module FFICXX.Generate.Builder where++import           Control.Monad                           ( void, when )+import qualified Data.ByteString.Lazy.Char8        as L+import           Data.Char                               ( toUpper )+import           Data.Digest.Pure.MD5                    ( md5 )+import           Data.Foldable                           ( for_ )+import           Data.Monoid                             ( (<>), mempty )+import           Language.Haskell.Exts.Pretty            ( prettyPrint )+import           System.FilePath                         ( (</>), (<.>), splitExtension )+import           System.Directory                        ( copyFile+                                                         , createDirectoryIfMissing+                                                         , doesFileExist+                                                         )+import           System.IO                               ( hPutStrLn, withFile, IOMode(..) )+import           System.Process                          ( readProcess )+--+import           FFICXX.Runtime.CodeGen.Cxx              ( HeaderName(..) )+--+import           FFICXX.Generate.Code.Cabal              ( buildCabalFile+                                                         , buildJSONFile+                                                         )+import           FFICXX.Generate.Dependency              ( findModuleUnitImports+                                                         , mkHSBOOTCandidateList+                                                         , mkPackageConfig+                                                         )+import           FFICXX.Generate.Config                  ( FFICXXConfig(..)+                                                         , SimpleBuilderConfig(..)+                                                         )+import           FFICXX.Generate.ContentMaker+import           FFICXX.Generate.Type.Cabal              ( Cabal(..)+                                                         , CabalName(..)+                                                         , AddCInc(..)+                                                         , AddCSrc(..)+                                                         )+import           FFICXX.Generate.Type.Class              ( hasProxy )+import           FFICXX.Generate.Type.Module             ( ClassImportHeader(..)+                                                         , ClassModule(..)+                                                         , PackageConfig(..)+                                                         , TemplateClassModule(..)+                                                         , TopLevelImportHeader(..)+                                                         )+import           FFICXX.Generate.Util                    ( moduleDirFile )+--++macrofy :: String -> String+macrofy = map ((\x->if x=='-' then '_' else x) . toUpper)+++simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO ()+simpleBuilder cfg sbc = do+  putStrLn "----------------------------------------------------"+  putStrLn "-- fficxx code generation for Haskell-C++ binding --"+  putStrLn "----------------------------------------------------"+  let SimpleBuilderConfig+        topLevelMod+        mumap+        cabal+        classes+        toplevelfunctions+        templates+        extralibs+        extramods+        staticFiles+        = sbc+      pkgname = cabal_pkgname cabal+  putStrLn ("Generating " <> unCabalName pkgname)+  let workingDir = fficxxconfig_workingDir cfg+      installDir = fficxxconfig_installBaseDir cfg+      staticDir  = fficxxconfig_staticFileDir cfg++      pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) =+        mkPackageConfig+          (pkgname, findModuleUnitImports mumap)+          (classes, toplevelfunctions,templates,extramods)+          (cabal_additional_c_incs cabal)+          (cabal_additional_c_srcs cabal)+      hsbootlst = mkHSBOOTCandidateList mods+      cabalFileName = unCabalName pkgname <.> "cabal"+      jsonFileName = unCabalName pkgname <.> "json"+  --+  createDirectoryIfMissing True workingDir+  createDirectoryIfMissing True installDir+  createDirectoryIfMissing True (installDir </> "src")+  createDirectoryIfMissing True (installDir </> "csrc")+  --+  putStrLn "Copying static files"+  mapM_ (\x->copyFileWithMD5Check (staticDir </> x) (installDir </> x)) staticFiles+  --+  putStrLn "Generating Cabal file"+  buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDir</>cabalFileName)+  --+  putStrLn "Generating JSON file"+  buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDir</>jsonFileName)+  --+  putStrLn "Generating Header file"+  let+      gen :: FilePath -> String -> IO ()+      gen file str =+        let path = workingDir </> file in withFile path WriteMode (flip hPutStrLn str)+++  gen (unCabalName pkgname <> "Type.h") (buildTypeDeclHeader (map cihClass cihs))+  for_ cihs $ \hdr -> gen+                        (unHdrName (cihSelfHeader hdr))+                        (buildDeclHeader (unCabalName pkgname) hdr)+  gen+    (tihHeaderFileName tih <.> "h")+    (buildTopLevelHeader (unCabalName pkgname) tih)++  putStrLn "Generating Cpp file"+  for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr))+  gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih)+  --+  putStrLn "Generating Additional Header/Source"+  for_ (cabal_additional_c_incs cabal) (\(AddCInc hdr txt) -> gen hdr txt)+  for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt)+  --+  putStrLn "Generating RawType.hs"+  for_ mods $ \m -> gen+                      (cmModule m <.> "RawType" <.> "hs")+                      (prettyPrint (buildRawTypeHs m))+  --+  putStrLn "Generating FFI.hsc"+  for_ mods $ \m -> gen+                      (cmModule m <.> "FFI" <.> "hsc")+                      (prettyPrint (buildFFIHsc m))+  --+  putStrLn "Generating Interface.hs"+  for_ mods $ \m -> gen+                      (cmModule m <.> "Interface" <.> "hs")+                      (prettyPrint (buildInterfaceHs mempty m))+  --+  putStrLn "Generating Cast.hs"+  for_ mods $ \m -> gen+                      (cmModule m <.> "Cast" <.> "hs")+                      (prettyPrint (buildCastHs m))+  --+  putStrLn "Generating Implementation.hs"+  for_ mods $ \m -> gen+                      (cmModule m <.> "Implementation" <.> "hs")+                      (prettyPrint (buildImplementationHs mempty m))+ --+  putStrLn "Generating Proxy.hs"+  for_ mods $ \m ->+    when (hasProxy . cihClass . cmCIH $ m) $+      gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (buildProxyHs m))+  --+  putStrLn "Generating Template.hs"+  for_ tcms $ \m -> gen+                      (tcmModule m <.> "Template" <.> "hs")+                      (prettyPrint (buildTemplateHs m))+  --+  putStrLn "Generating TH.hs"+  for_ tcms $ \m -> gen+                      (tcmModule m <.> "TH" <.> "hs")+                      (prettyPrint (buildTHHs m))++  --+  -- TODO: Template.hs-boot need to be generated as well+  putStrLn "Generating hs-boot file"+  for_ hsbootlst $ \m -> gen+                           (m <.> "Interface" <.> "hs-boot")+                           (prettyPrint (buildInterfaceHSBOOT m))+  --+  putStrLn "Generating Module summary file"+  for_ mods $ \m -> gen+                      (cmModule m <.> "hs")+                      (prettyPrint (buildModuleHs m))+  --+  putStrLn "Generating Top-level Module"+  gen (topLevelMod <.> "hs") (prettyPrint (buildTopLevelHs topLevelMod (mods,tcms) tih))+  --+  putStrLn "Copying generated files to target directory"+  touch (workingDir </> "LICENSE")+  copyFileWithMD5Check (workingDir </> cabalFileName)  (installDir </> cabalFileName)+  copyFileWithMD5Check (workingDir </> jsonFileName)  (installDir </> jsonFileName)+  copyFileWithMD5Check (workingDir </> "LICENSE") (installDir </> "LICENSE")++  copyCppFiles workingDir (csrcDir installDir) (unCabalName pkgname) pkgconfig+  for_ mods (copyModule workingDir (srcDir installDir))+  for_ tcms (copyTemplateModule workingDir (srcDir installDir))+  moduleFileCopy workingDir (srcDir installDir) $ topLevelMod <.> "hs"++  putStrLn "----------------------------------------------------"+  putStrLn "-- Code generation has been completed. Enjoy!     --"+  putStrLn "----------------------------------------------------"+++-- | some dirty hack. later, we will do it with more proper approcah.++touch :: FilePath -> IO ()+touch fp = void (readProcess "touch" [fp] "")+++copyFileWithMD5Check :: FilePath -> FilePath -> IO ()+copyFileWithMD5Check src tgt = do+  b <- doesFileExist tgt+  if b+    then do+      srcmd5 <- md5 <$> L.readFile src+      tgtmd5 <- md5 <$> L.readFile tgt+      if srcmd5 == tgtmd5 then return () else copyFile src tgt+    else copyFile src tgt+++copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO ()+copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ _tcihs acincs acsrcs) = do+  let thfile = cprefix <> "Type.h"+      tlhfile = tihHeaderFileName tih <.> "h"+      tlcppfile = tihHeaderFileName tih <.> "cpp"+  copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile)+  doesFileExist (wdir </> tlhfile)+    >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))+  doesFileExist (wdir </> tlcppfile)+    >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))+  for_ cihs $ \header-> do+    let hfile = unHdrName (cihSelfHeader header)+        cppfile = cihSelfCpp header+    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile)+    copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)++  for_ acincs $ \(AddCInc header _) ->+    copyFileWithMD5Check (wdir </> header) (ddir </> header)++  for_ acsrcs $ \(AddCSrc csrc _) ->+    copyFileWithMD5Check (wdir </> csrc) (ddir </> csrc)+++moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO ()+moduleFileCopy wdir ddir fname = do+  let (fnamebody,fnameext) = splitExtension fname+      (mdir,mfile) = moduleDirFile fnamebody+      origfpath = wdir </> fname+      (mfile',_mext') = splitExtension mfile+      newfpath = ddir </> mdir </> mfile' <> fnameext+  b <- doesFileExist origfpath+  when b $ do+    createDirectoryIfMissing True (ddir </> mdir)+    copyFileWithMD5Check origfpath newfpath+++copyModule :: FilePath -> FilePath -> ClassModule -> IO ()+copyModule wdir ddir m = do+  let modbase = cmModule m+  moduleFileCopy wdir ddir $ modbase <> ".hs"+  moduleFileCopy wdir ddir $ modbase <> ".RawType.hs"+  moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc"+  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs"+  moduleFileCopy wdir ddir $ modbase <> ".Cast.hs"+  moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs"+  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot"+  when (hasProxy . cihClass . cmCIH $ m) $+    moduleFileCopy wdir ddir $ modbase <> ".Proxy.hs"+++copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO ()+copyTemplateModule wdir ddir m = do+  let modbase = tcmModule m+  moduleFileCopy wdir ddir $ modbase <> ".Template.hs"+  moduleFileCopy wdir ddir $ modbase <> ".TH.hs"

@@ -0,0 +1,283 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module FFICXX.Generate.Code.Cabal where++import Data.Aeson.Encode.Pretty    (encodePretty)+import qualified Data.ByteString.Lazy as BL+import Data.List                   (intercalate, nub)+import Data.Monoid                 ((<>))+import Data.Text                   (Text)+import Data.Text.Template          (substitute)+import qualified Data.Text as T    (intercalate,pack,replicate,unlines)+import qualified Data.Text.Lazy as TL (toStrict)+import qualified Data.Text.IO as TIO (writeFile)+import System.FilePath             ((<.>),(</>))+--+import FFICXX.Runtime.CodeGen.Cxx  ( HeaderName(..) )+--+import FFICXX.Generate.Type.Cabal  ( AddCInc(..)+                                   , AddCSrc(..)+                                   , BuildType(..)+                                   , CabalName(..)+                                   , Cabal(..)+                                   , GeneratedCabalInfo(..)+                                   )+import FFICXX.Generate.Type.Class  ( hasProxy )+import FFICXX.Generate.Type.Module+-- import FFICXX.Generate.Type.PackageInterface+import FFICXX.Generate.Util+++cabalIndentation :: Text+cabalIndentation = T.replicate 23 " "+++unlinesWithIndent = T.unlines . map (cabalIndentation <>)++-- for source distribution+genCsrcFiles :: (TopLevelImportHeader,[ClassModule])+             -> [AddCInc]+             -> [AddCSrc]+             -> [String]+genCsrcFiles (tih,cmods) acincs acsrcs =+  let selfheaders' = do+        x <- cmods+        let y = cmCIH x+        return (cihSelfHeader y)+      selfheaders = nub selfheaders'+      selfcpp' = do+        x <- cmods+        let y = cmCIH x+        return (cihSelfCpp y)+      selfcpp = nub selfcpp'+      tlh = tihHeaderFileName tih <.> "h"+      tlcpp = tihHeaderFileName tih <.> "cpp"+      includeFileStrsWithCsrc = map (\x->"csrc"</> x) $+                                 (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders))+                                 ++ map (\(AddCInc hdr _) -> hdr) acincs+      cppFilesWithCsrc = map (\x->"csrc"</>x)  $+                           (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)+                           ++ map (\(AddCSrc src _) -> src) acsrcs+++  in includeFileStrsWithCsrc <> cppFilesWithCsrc++-- for library+genIncludeFiles :: String        -- ^ package name+                -> ([ClassImportHeader],[TemplateClassImportHeader])+                -> [AddCInc]+                -> [String]+genIncludeFiles pkgname (cih,_tcih) acincs =+  let selfheaders = map cihSelfHeader cih+      includeFileStrs = map unHdrName (selfheaders ++ map (\(AddCInc hdr _) -> HdrName hdr) acincs)+  in (pkgname<>"Type.h") : includeFileStrs++-- for library+genCppFiles :: (TopLevelImportHeader,[ClassModule])+            -> [AddCSrc]+            -> [String]+genCppFiles (tih,cmods) acsrcs =+  let selfcpp' = do+        x <- cmods+        let y = cmCIH x+        return (cihSelfCpp y)+      selfcpp = nub selfcpp'+      tlcpp = tihHeaderFileName tih <.> "cpp"+      cppFileStrs = map (\x -> "csrc" </> x)  $+                      (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)+                      ++ map (\(AddCSrc src _) -> src) acsrcs+  in cppFileStrs++-- | generate exposed module list in cabal file+genExposedModules :: String -> ([ClassModule],[TemplateClassModule]) -> [String]+genExposedModules summarymod (cmods,tmods) =+  let cmodstrs       = map cmModule cmods+      rawType        = map ((<>".RawType")        . cmModule) cmods+      ffi            = map (( <>".FFI")           . cmModule) cmods+      interface      = map ((<>".Interface")      . cmModule) cmods+      cast           = map ((<>".Cast")           . cmModule) cmods+      implementation = map ((<>".Implementation") . cmModule) cmods+      proxy          = map ((<>".Proxy")          . cmModule)+                     . filter (hasProxy . cihClass . cmCIH)+                     $ cmods+      template       = map ((<>".Template")       . tcmModule) tmods+      th             = map ((<>".TH")             . tcmModule) tmods+  in    [summarymod]+     <> cmodstrs+     <> rawType+     <> ffi+     <> interface+     <> cast+     <> implementation+     <> proxy+     <> template+     <> th++-- | generate other modules in cabal file+genOtherModules :: [ClassModule] -> [String]+genOtherModules _cmods = [""]++-- | generate additional package dependencies.+genPkgDeps :: [CabalName] -> [String]+genPkgDeps cs =    [ "base > 4 && < 5"+                   , "fficxx >= 0.5"+                   , "fficxx-runtime >= 0.5"+                   , "template-haskell"+                   ]+                ++ map unCabalName cs++++-- |+cabalTemplate :: Text+cabalTemplate =+  "Name:                $pkgname\n\+  \Version:     $version\n\+  \Synopsis:    $synopsis\n\+  \Description:         $description\n\+  \Homepage:       $homepage\n\+  \$licenseField\n\+  \$licenseFileField\n\+  \Author:              $author\n\+  \Maintainer:  $maintainer\n\+  \Category:       $category\n\+  \Tested-with:    GHC >= 7.6\n\+  \$buildtype\n\+  \cabal-version:  >= 2\n\+  \Extra-source-files:\n\+  \$extraFiles\n\+  \$csrcFiles\n\+  \\n\+  \$sourcerepository\n\+  \\n\+  \Library\n\+  \  default-language: Haskell2010\n\+  \  hs-source-dirs: src\n\+  \  ghc-options:  -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\+  \  ghc-prof-options: -caf-all -auto-all\n\+  \  cxx-options: $cxxOptions\n\+  \  Build-Depends: $pkgdeps\n\+  \  Exposed-Modules:\n\+  \$exposedModules\n\+  \  Other-Modules:\n\+  \$otherModules\n\+  \  extra-lib-dirs: $extralibdirs\n\+  \  extra-libraries:    $extraLibraries\n\+  \  Include-dirs:       csrc $extraincludedirs\n\+  \  pkgconfig-depends: $pkgconfigDepends\n\+  \  Install-includes:\n\+  \$includeFiles\n\+  \  C-sources:\n\+  \$cppFiles\n"++++-- TODO: remove all T.pack after we switch over to Text+genCabalInfo+  :: Cabal+  -> String+  -> PackageConfig+  -> [String] -- ^ extra libs+  -> GeneratedCabalInfo+genCabalInfo cabal summarymodule pkgconfig extralibs =+  let tih = pcfg_topLevelImportHeader pkgconfig+      classmodules = pcfg_classModules pkgconfig+      cih = pcfg_classImportHeaders pkgconfig+      tmods = pcfg_templateClassModules pkgconfig+      tcih = pcfg_templateClassImportHeaders pkgconfig+      acincs = pcfg_additional_c_incs pkgconfig+      acsrcs = pcfg_additional_c_srcs pkgconfig+      extrafiles = cabal_extrafiles cabal+  in GeneratedCabalInfo {+       gci_pkgname          = T.pack (unCabalName (cabal_pkgname cabal))+     , gci_version          = T.pack (cabal_version cabal)+     , gci_synopsis         = ""+     , gci_description      = ""+     , gci_homepage         = ""+     , gci_license          = maybe "" T.pack (cabal_license cabal)+     , gci_licenseFile      = maybe "" T.pack (cabal_licensefile cabal)+     , gci_author           = ""+     , gci_maintainer       = ""+     , gci_category         = ""+     , gci_buildtype        = case cabal_buildType cabal of+                                Simple ->+                                  "Build-Type: Simple"+                                Custom deps ->+                                     "Build-Type: Custom\ncustom-setup\n  setup-depends: "+                                  <> T.pack (intercalate ", " (map unCabalName deps))+                                  <> "\n"+     , gci_extraFiles       = map T.pack extrafiles+     , gci_csrcFiles        = map T.pack $ genCsrcFiles (tih,classmodules) acincs acsrcs+     , gci_sourcerepository = ""+     , gci_cxxOptions       = ["-std=c++14"]+     , gci_pkgdeps          = map T.pack $ genPkgDeps (cabal_additional_pkgdeps cabal)+     , gci_exposedModules   = map T.pack $ genExposedModules summarymodule (classmodules,tmods)+     , gci_otherModules     = map T.pack $ genOtherModules classmodules+     , gci_extraLibDirs     = map T.pack $ cabal_extralibdirs cabal+     , gci_extraLibraries   = map T.pack extralibs+     , gci_extraIncludeDirs = map T.pack $ cabal_extraincludedirs cabal+     , gci_pkgconfigDepends = map T.pack $ cabal_pkg_config_depends cabal+     , gci_includeFiles     = map T.pack $ genIncludeFiles (unCabalName (cabal_pkgname cabal)) (cih,tcih) acincs+     , gci_cppFiles         = map T.pack $ genCppFiles (tih,classmodules) acsrcs+     }+++genCabalFile :: GeneratedCabalInfo -> Text+genCabalFile GeneratedCabalInfo {..} =+  TL.toStrict $+    substitute cabalTemplate $+      contextT [ ("licenseField"    , "license: " <> gci_license)+               , ("licenseFileField", "license-file: " <> gci_licenseFile)+               , ("pkgname"         , gci_pkgname)+               , ("version"         , gci_version)+               , ("buildtype"       , gci_buildtype)+               , ("synopsis"        , gci_synopsis)+               , ("description"     , gci_description)+               , ("homepage"        , gci_homepage)+               , ("author"          , gci_author)+               , ("maintainer"      , gci_maintainer)+               , ("category"        , gci_category)+               , ("sourcerepository", gci_sourcerepository)+               , ("cxxOptions"       , T.intercalate " " gci_cxxOptions)+               , ("pkgdeps"         , T.intercalate ", " gci_pkgdeps)+               , ("extraFiles"      , unlinesWithIndent gci_extraFiles)+               , ("csrcFiles"       , unlinesWithIndent gci_csrcFiles)+               , ("includeFiles"    , unlinesWithIndent gci_includeFiles)+               , ("cppFiles"        , unlinesWithIndent gci_cppFiles)+               , ("exposedModules"  , unlinesWithIndent gci_exposedModules)+               , ("otherModules"    , unlinesWithIndent gci_otherModules)+               , ("extralibdirs"    , T.intercalate ", " gci_extraLibDirs)+               , ("extraincludedirs", T.intercalate ", " gci_extraIncludeDirs)+               , ("extraLibraries"  , T.intercalate ", " gci_extraLibraries)+               , ("cabalIndentation", cabalIndentation)+               , ("pkgconfigDepends", T.intercalate ", " gci_pkgconfigDepends)+               ]+++-- |+buildCabalFile+  :: Cabal+  -> String+  -> PackageConfig+  -> [String]      -- ^ Extra libs+  -> FilePath      -- ^ Cabal file path+  -> IO ()+buildCabalFile cabal summarymodule pkgconfig extralibs cabalfile = do+  let+      cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs+      txt = genCabalFile cinfo+  TIO.writeFile cabalfile txt+++-- |+buildJSONFile+  :: Cabal+  -> String+  -> PackageConfig+  -> [String]      -- ^ Extra libs+  -> FilePath      -- ^ JSON file path+  -> IO ()+buildJSONFile cabal summarymodule pkgconfig extralibs jsonfile = do+  let cinfo = genCabalInfo cabal summarymodule pkgconfig extralibs+  BL.writeFile jsonfile (encodePretty cinfo)

@@ -0,0 +1,711 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module FFICXX.Generate.Code.Cpp where++import Data.Char             ( toUpper )+import Data.Functor.Identity ( Identity )+import Data.List             ( intercalate, intersperse )+import Data.Monoid           ( (<>) )+--+import qualified FFICXX.Runtime.CodeGen.Cxx as R+import FFICXX.Runtime.TH     ( IsCPrimitive(CPrim, NonCPrim) )+--+import FFICXX.Generate.Code.Primitive+                                    ( accessorCFunSig+                                    , argToCallCExp+                                    , argsToCTypVar+                                    , argsToCTypVarNoSelf+                                    , c2Cxx+                                    , cxx2C+                                    , CFunSig(..)+                                    , genericFuncArgs+                                    , genericFuncRet+                                    , returnCType+                                    , tmplAccessorToTFun+                                    , tmplAllArgsToCTypVar+                                    , tmplAppTypeFromForm+                                    , tmplArgToCallCExp+                                    , tmplMemFuncArgToCTypVar+                                    , tmplMemFuncReturnCType+                                    , tmplReturnCType+                                    )+import FFICXX.Generate.Name         ( aliasedFuncName+                                    , cppFuncName+                                    , ffiClassName+                                    , ffiTmplFuncName+                                    , hsTemplateMemberFunctionName+                                    )+import FFICXX.Generate.Type.Class   ( Accessor(Getter,Setter)+                                    , Arg(..)+                                    , Class(..)+                                    , CPPTypes(..)+                                    , CTypes(..)+                                    , Form(FormSimple,FormNested)+                                    , Function(..)+                                    , IsConst(Const,NoConst)+                                    , Selfness(NoSelf,Self)+                                    , TemplateAppInfo(..)+                                    , TemplateClass(..)+                                    , TemplateFunction(..)+                                    , TemplateMemberFunction(..)+                                    , TopLevel(..)+                                    , Types(..)+                                    , Variable(..)+                                    , argsFromOpExp+                                    , isDeleteFunc+                                    , isNewFunc+                                    , isStaticFunc+                                    , isVirtualFunc+                                    , opSymbol+                                    , virtualFuncs+                                    )+import FFICXX.Generate.Type.Module  ( ClassImportHeader(..) )+import FFICXX.Generate.Util         ( toUppers )++--+--+-- Class Declaration and Definition+--++----+---- Declaration+----++---- "Class Type Declaration" Instances++typedefStmts :: String -> [R.CStatement Identity]+typedefStmts classname =+    [ R.TypeDef (R.CTVerbatim ("struct " <> classname_tag)) (R.sname classname_t)+    , R.TypeDef (R.CTVerbatim (classname_t <> " *"))        (R.sname classname_p)+    , R.TypeDef (R.CTVerbatim (classname_t <> " const*"))   (R.sname ("const_" <> classname_p))+    ]+  where+    classname_tag = classname <> "_tag"+    classname_t   = classname <> "_t"+    classname_p   = classname <> "_p"+++genCppHeaderMacroType :: Class -> [R.CStatement Identity]+genCppHeaderMacroType c =+    [ R.Comment "Opaque type definition for $classname" ]+    <> typedefStmts (ffiClassName c)+++---- "Class Declaration Virtual" Declaration++genCppHeaderMacroVirtual :: Class -> R.CMacro Identity+genCppHeaderMacroVirtual aclass =+  let funcDecls = map R.CDeclaration+                . map (funcToDecl aclass)+                . virtualFuncs+                . class_funcs+                $ aclass+      macrocname = map toUpper (ffiClassName aclass)+      macroname = macrocname <> "_DECL_VIRT"+  in R.Define (R.sname macroname) [R.sname "Type"] funcDecls++genCppHeaderMacroNonVirtual :: Class -> R.CMacro Identity+genCppHeaderMacroNonVirtual c =+  let funcDecls = map R.CDeclaration+                . map (funcToDecl c)+                . filter (not.isVirtualFunc)+                . class_funcs+                $ c+      macrocname = map toUpper (ffiClassName c)+      macroname = macrocname <> "_DECL_NONVIRT"+  in R.Define (R.sname macroname) [R.sname "Type"] funcDecls+++---- "Class Declaration Accessor" Declaration++genCppHeaderMacroAccessor :: Class -> R.CMacro Identity+genCppHeaderMacroAccessor c =+  let funcDecls  = map R.CDeclaration $ accessorsToDecls (class_vars c)+      macrocname = map toUpper (ffiClassName c)+      macroname  = macrocname <> "_DECL_ACCESSOR"+  in R.Define (R.sname macroname) [R.sname "Type"] funcDecls+++---- "Class Declaration Virtual/NonVirtual/Accessor" Instances++genCppHeaderInstVirtual :: (Class,Class) -> R.CStatement Identity+genCppHeaderInstVirtual (p,c) =+  let macroname = map toUpper (ffiClassName p) <> "_DECL_VIRT"+  in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)]++genCppHeaderInstNonVirtual :: Class -> R.CStatement Identity+genCppHeaderInstNonVirtual c =+  let macroname = map toUpper (ffiClassName c) <> "_DECL_NONVIRT"+  in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)]++genCppHeaderInstAccessor :: Class -> R.CStatement Identity+genCppHeaderInstAccessor c =+  let macroname = map toUpper (ffiClassName c) <> "_DECL_ACCESSOR"+  in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)]++----+---- Definition+----++---- "Class Definition Virtual" Declaration++genCppDefMacroVirtual :: Class -> R.CMacro Identity+genCppDefMacroVirtual aclass =+  let funcDefStr = intercalate "\n"+                 . map (R.renderCStmt . funcToDef aclass)+                 . virtualFuncs+                 . class_funcs+                 $ aclass+      macrocname = map toUpper (ffiClassName aclass)+      macroname = macrocname <> "_DEF_VIRT"+  in R.Define (R.sname macroname) [R.sname "Type"] [ R.CVerbatim funcDefStr ]++---- "Class Definition NonVirtual" Declaration++genCppDefMacroNonVirtual :: Class -> R.CMacro Identity+genCppDefMacroNonVirtual aclass =+  let funcDefStr = intercalate "\n"+                 . map (R.renderCStmt . funcToDef aclass)+                 . filter (not.isVirtualFunc)+                 . class_funcs+                 $ aclass+      macrocname = map toUpper (ffiClassName aclass)+      macroname = macrocname <> "_DEF_NONVIRT"+  in R.Define (R.sname macroname) [R.sname "Type"] [ R.CVerbatim funcDefStr ]++---- Define Macro to provide Accessor C-C++ shim code for a class++genCppDefMacroAccessor :: Class -> R.CMacro Identity+genCppDefMacroAccessor c =+  let funcDefs = concatMap (\v -> [accessorToDef v Getter,accessorToDef v Setter]) (class_vars c)+      macrocname = map toUpper (ffiClassName c)+      macroname = macrocname <> "_DEF_ACCESSOR"+  in R.Define (R.sname macroname) [R.sname "Type"] funcDefs++---- Define Macro to provide TemplateMemberFunction C-C++ shim code for a class++genCppDefMacroTemplateMemberFunction ::+     Class+  -> TemplateMemberFunction+  -> R.CMacro Identity+genCppDefMacroTemplateMemberFunction c f =+   R.Define (R.sname macroname) (map R.sname (tmf_params f))+     [ R.CExtern [R.CDeclaration decl]+     , tmplMemberFunToDef c f+     , autoinst+     ]+  where+    nsuffix = intersperse (R.NamePart "_") $ map R.NamePart (tmf_params f)+    macroname = hsTemplateMemberFunctionName c f+    decl = tmplMemberFunToDecl c f+    autoinst =+      R.CInit+        (R.CVarDecl+          R.CTAuto+          (R.CName (R.NamePart ("a_" <> macroname <> "_") : nsuffix))+        )+        (R.CVar (R.CName (R.NamePart (macroname <> "_") : nsuffix)))+++---- Invoke Macro to define Virtual/NonVirtual method for a class++genCppDefInstVirtual :: (Class, Class) -> R.CStatement Identity+genCppDefInstVirtual (p,c) =+  let macroname = map toUpper (ffiClassName p) <> "_DEF_VIRT"+  in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)]++genCppDefInstNonVirtual :: Class -> R.CStatement Identity+genCppDefInstNonVirtual c =+  let macroname = toUppers (ffiClassName c) <> "_DEF_NONVIRT"+  in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)]++genCppDefInstAccessor :: Class -> R.CStatement Identity+genCppDefInstAccessor c =+  let macroname = toUppers (ffiClassName c) <> "_DEF_ACCESSOR"+  in R.CMacroApp (R.sname macroname) [R.sname (ffiClassName c)]++-----------------++genAllCppHeaderInclude :: ClassImportHeader -> [R.CMacro Identity]+genAllCppHeaderInclude header =+  map R.Include (cihIncludedHPkgHeadersInCPP header <> cihIncludedCPkgHeaders header)++----++-------------------------+-- TOP LEVEL FUNCTIONS --+-------------------------++topLevelDecl :: TopLevel -> R.CFunDecl Identity+topLevelDecl TopLevelFunction {..} = R.CFunDecl ret func args+  where+    ret  = returnCType toplevelfunc_ret+    func = R.sname ("TopLevel_" <> maybe toplevelfunc_name id toplevelfunc_alias)+    args = argsToCTypVarNoSelf toplevelfunc_args+topLevelDecl TopLevelVariable {..} = R.CFunDecl ret func []+  where+    ret  = returnCType toplevelvar_ret+    func = R.sname ("TopLevel_" <> maybe toplevelvar_name id toplevelvar_alias)++genTopLevelCppDefinition :: TopLevel -> R.CStatement Identity+genTopLevelCppDefinition tf@TopLevelFunction {..} =+  let decl = topLevelDecl tf+      body = returnCpp+               NonCPrim+               (toplevelfunc_ret)+               (R.CApp (R.CVar (R.sname toplevelfunc_name)) (map argToCallCExp toplevelfunc_args))+  in R.CDefinition Nothing decl body+genTopLevelCppDefinition tv@TopLevelVariable {..} =+  let decl = topLevelDecl tv+      body = returnCpp NonCPrim (toplevelvar_ret) (R.CVar (R.sname toplevelvar_name))+  in R.CDefinition Nothing decl body++genTmplFunCpp ::+     IsCPrimitive+  -> TemplateClass+  -> TemplateFunction+  -> R.CMacro Identity+genTmplFunCpp b t@TmplCls {..} f =+    R.Define (R.sname macroname) (map R.sname ("callmod" : tclass_params))+      [ R.CExtern [R.CDeclaration decl]+      , tmplFunToDef b t f+      , autoinst+      ]+ where+  nsuffix = intersperse (R.NamePart "_") $ map R.NamePart tclass_params+  suffix = case b of { CPrim -> "_s"; NonCPrim -> "" }+  macroname = tclass_name <> "_" <> ffiTmplFuncName f <> suffix+  decl = tmplFunToDecl b t f+  autoinst =+    R.CInit+      (R.CVarDecl+        R.CTAuto+        (R.CName (R.NamePart "a_" : R.NamePart "callmod" : R.NamePart ("_" <> tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix ))+      )+      (R.CVar (R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix )))++genTmplVarCpp ::+     IsCPrimitive+  -> TemplateClass+  -> Variable+  -> [ R.CMacro Identity ]+genTmplVarCpp b t@TmplCls {..} var@(Variable (Arg {..})) =+    [ gen var Getter, gen var Setter ]+  where+    nsuffix = intersperse (R.NamePart "_") $ map R.NamePart tclass_params+    suffix = case b of { CPrim -> "_s"; NonCPrim -> "" }+    gen v a =+      let f = tmplAccessorToTFun v a+          macroname = tclass_name <> "_" <> ffiTmplFuncName f <> suffix+      in R.Define (R.sname macroname) (map R.sname ("callmod" : tclass_params))+           [ R.CExtern [R.CDeclaration (tmplFunToDecl b t f)]+           , tmplVarToDef b t v a+           , R.CInit+               (R.CVarDecl+                 R.CTAuto+                 (R.CName (R.NamePart "a_" : R.NamePart "callmod" : R.NamePart ("_" <> tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix ))+           )+               (R.CVar (R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix )))+           ]++-- |+genTmplClassCpp ::+     IsCPrimitive+  -> TemplateClass+  -> ([TemplateFunction],[Variable]) -- ^ (member functions, member accessors)+  -> R.CMacro Identity+genTmplClassCpp b TmplCls {..} (fs,vs) =+    R.Define (R.sname macroname) params body+ where+  params = map R.sname ("callmod" : tclass_params)+  suffix = case b of { CPrim -> "_s"; NonCPrim -> "" }+  tname = tclass_name+  macroname = tname <> "_instance" <> suffix+  macro1 f@TFun {..}    = R.CMacroApp (R.sname (tname <> "_" <> ffiTmplFuncName f <> suffix)) params+  macro1 f@TFunNew {..} = R.CMacroApp (R.sname (tname <> "_" <> ffiTmplFuncName f <> suffix)) params+  macro1 TFunDelete     = R.CMacroApp (R.sname (tname <> "_delete" <> suffix)) params+  macro1 f@TFunOp {..}  = R.CMacroApp (R.sname (tname <> "_" <> ffiTmplFuncName f <> suffix)) params+  body =    map macro1 fs+         ++ (map macro1 . concatMap (\v -> [tmplAccessorToTFun v Getter, tmplAccessorToTFun v Setter])) vs++-- |+returnCpp ::+     IsCPrimitive+  -> Types+  -> R.CExp Identity+  -> [R.CStatement Identity]+returnCpp b ret caller =+  case ret of+    Void ->+      [ R.CExpSA caller ]+    SelfType ->+      [R.CReturn $+        R.CTApp+          (R.sname "from_nonconst_to_nonconst")+          [ R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t" ])+          , R.CTSimple (R.sname "Type") ]+          [ R.CCast (R.CTStar (R.CTSimple (R.sname "Type"))) caller ]+      ]+    CT (CRef _) _ ->+      [R.CReturn $ R.CAddr caller ]+    CT _ _ ->+      [R.CReturn caller ]+    CPT (CPTClass c') isconst ->+      [R.CReturn $+        R.CTApp+          (case isconst of+              NoConst -> R.sname "from_nonconst_to_nonconst"+              Const   -> R.sname "from_const_to_nonconst" +          )+          [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ]+          [ R.CCast (R.CTStar (R.CTSimple (R.sname str))) caller ]+      ]+      where str = ffiClassName c'+    CPT (CPTClassRef c') isconst ->+      [R.CReturn $+        R.CTApp+          (case isconst of+             NoConst -> R.sname "from_nonconst_to_nonconst"+             Const   -> R.sname "from_const_to_nonconst"+          )+          [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ]+          [ R.CAddr caller ]+      ]+      where str = ffiClassName c'+    CPT (CPTClassCopy c') isconst ->+      [R.CReturn $+        R.CTApp+          (case isconst of+             NoConst -> R.sname "from_nonconst_to_nonconst"+             Const   -> R.sname "from_const_to_nonconst"+          )+          [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ]+          [ R.CNew (R.sname str) [ caller ]  ]+      ]+      where str = ffiClassName c'+    CPT (CPTClassMove c') isconst -> -- TODO: check whether this is working or not.+      [R.CReturn $+        R.CApp+          (R.CVar (R.sname "std::move"))+          [R.CTApp+            (case isconst of+               NoConst -> R.sname "from_nonconst_to_nonconst"+               Const   -> R.sname "from_const_to_nonconst"+            )+            [ R.CTSimple (R.sname (str <> "_t")), R.CTSimple (R.sname str) ]+            [ R.CAddr caller ]+          ]+      ]+      where str = ffiClassName c'+    TemplateApp (TemplateAppInfo _ _ cpptype) ->+      [ R.CInit+          (R.CVarDecl (R.CTStar (R.CTVerbatim cpptype)) (R.sname "r"))+          (R.CNew (R.sname cpptype) [ caller ])+      , R.CReturn $+          R.CTApp+            (R.sname "static_cast")+            [ R.CTStar R.CTVoid ]+            [ R.CVar (R.sname "r") ]+      ]+    TemplateAppRef (TemplateAppInfo _ _ cpptype) ->+      [ R.CInit+          (R.CVarDecl (R.CTStar (R.CTVerbatim cpptype)) (R.sname "r"))+          (R.CNew (R.sname cpptype) [ caller ])+      , R.CReturn $+          R.CTApp+            (R.sname "static_cast")+            [ R.CTStar R.CTVoid ]+            [ R.CVar (R.sname "r") ]+      ]+    TemplateAppMove (TemplateAppInfo _ _ cpptype) ->+      [ R.CInit+          (R.CVarDecl (R.CTStar (R.CTVerbatim cpptype)) (R.sname "r"))+          (R.CNew (R.sname cpptype) [ caller ])+      , R.CReturn $+          R.CApp+            (R.CVar (R.sname "std::move"))+            [R.CTApp+              (R.sname "staic_cast")+              [ R.CTStar R.CTVoid ]+              [ R.CVar (R.sname "r") ]+            ]+      ]+    TemplateType _ ->+      error "returnCpp: TemplateType"+    TemplateParam typ ->+      [ R.CReturn $+          case b of+            CPrim    -> caller+            NonCPrim ->+              R.CTApp+                (R.sname "from_nonconst_to_nonconst")+                [ R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t" ]), R.CTSimple (R.sname typ) ]+                [ R.CCast (R.CTStar (R.CTSimple (R.sname typ))) $ R.CAddr caller ]+      ]+    TemplateParamPointer typ ->+      [ R.CReturn $+          case b of+            CPrim    -> caller+            NonCPrim ->+              R.CTApp+                (R.sname "from_nonconst_to_nonconst")+                [ R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t"]), R.CTSimple (R.sname typ) ]+                [ caller ]+      ]++-- Function Declaration and Definition++funcToDecl :: Class -> Function -> R.CFunDecl Identity+funcToDecl c func+  | isNewFunc func || isStaticFunc func =+    let ret   = returnCType (genericFuncRet func)+        fname =+          R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)]+        args  = argsToCTypVarNoSelf (genericFuncArgs func)+    in R.CFunDecl ret fname args+  | otherwise =+    let ret   = returnCType (genericFuncRet func)+        fname =+          R.CName [R.NamePart "Type", R.NamePart ("_" <> aliasedFuncName c func)]+        args  = argsToCTypVar (genericFuncArgs func)+    in R.CFunDecl ret fname args++funcToDef :: Class -> Function -> R.CStatement Identity+funcToDef c func+  | isNewFunc func =+    let body = [ R.CInit+                   (R.CVarDecl (R.CTStar (R.CTSimple (R.sname "Type"))) (R.sname "newp"))+                   (R.CNew (R.sname "Type") $ map argToCallCExp (genericFuncArgs func))+               , R.CReturn $+                   R.CTApp+                     (R.sname "from_nonconst_to_nonconst")+                     [ R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t"]), R.CTSimple (R.sname "Type") ]+                     [ R.CVar (R.sname "newp") ]+               ]+    in R.CDefinition Nothing (funcToDecl c func) body+  | isDeleteFunc func =+    let body = [ R.CDelete $+                   R.CTApp+                     (R.sname "from_nonconst_to_nonconst")+                     [ R.CTSimple (R.sname "Type"), R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t" ]) ]+                     [ R.CVar (R.sname "p") ]+               ]+    in R.CDefinition Nothing (funcToDecl c func) body+  | isStaticFunc func =+    let body = returnCpp NonCPrim (genericFuncRet func) $+                 R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func))+    in R.CDefinition Nothing (funcToDecl c func) body+  | otherwise =+    let caller =+          R.CBinOp+            R.CArrow+            (R.CApp+              (R.CEMacroApp+                (R.sname "TYPECASTMETHOD")+                [ R.sname "Type", R.sname (aliasedFuncName c func), R.sname (class_name c) ]+              )+              [ R.CVar (R.sname "p") ]+            )+            (R.CApp (R.CVar (R.sname (cppFuncName c func))) (map argToCallCExp (genericFuncArgs func)))+        body = returnCpp NonCPrim (genericFuncRet func) caller+    in R.CDefinition Nothing (funcToDecl c func) body++-- template function declaration and definition+++tmplFunToDecl ::+     IsCPrimitive+  -> TemplateClass+  -> TemplateFunction+  -> R.CFunDecl Identity+tmplFunToDecl b t@TmplCls {..} f =+  let nsuffix = intersperse (R.NamePart "_") $ map R.NamePart tclass_params+  in case f of+    TFun {..} ->+      let ret  = tmplReturnCType b tfun_ret+          func = R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix)+          args = tmplAllArgsToCTypVar b Self t tfun_args+      in R.CFunDecl ret func args+    TFunNew {..} ->+      let ret  = tmplReturnCType b (TemplateType t)+          func = R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix)+          args = tmplAllArgsToCTypVar b NoSelf t tfun_new_args+      in R.CFunDecl ret func args+    TFunDelete ->+      let ret  = R.CTVoid+          func = R.CName (R.NamePart (tclass_name <> "_delete_") : nsuffix)+          args = tmplAllArgsToCTypVar b Self t []+      in R.CFunDecl ret func args+    TFunOp {..} ->+      let ret  = tmplReturnCType b tfun_ret+          func = R.CName (R.NamePart (tclass_name <> "_" <> ffiTmplFuncName f <> "_") : nsuffix)+          args = tmplAllArgsToCTypVar b Self t (argsFromOpExp tfun_opexp)+      in R.CFunDecl ret func args++-- |+tmplFunToDef ::+     IsCPrimitive+  -> TemplateClass+  -> TemplateFunction+  -> R.CStatement Identity+tmplFunToDef b t@TmplCls {..} f =+    R.CDefinition (Just R.Inline) (tmplFunToDecl b t f) body+  where+    typparams = map (R.CTSimple . R.sname) tclass_params+    body =+      case f of+        TFunNew {..} ->+          let caller =+                case tclass_cxxform of+                  FormSimple tclass ->+                    R.CTNew+                      (R.sname tclass)+                      typparams+                      (map (tmplArgToCallCExp b) tfun_new_args)+                  FormNested tclass inner ->+                    R.CTNewI+                      (R.sname tclass)+                      (R.sname inner)+                      typparams+                      (map (tmplArgToCallCExp b) tfun_new_args)+          in  [ R.CReturn $ R.CTApp (R.sname "static_cast") [R.CTStar R.CTVoid] [caller] ]+        TFunDelete ->+          [ R.CDelete $+              R.CTApp+                (R.sname "static_cast")+                [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ]+                [ R.CVar (R.sname "p") ]+          ]+        TFun {..}    ->+          returnCpp b (tfun_ret) $+            R.CBinOp+              R.CArrow+              (R.CTApp+                 (R.sname "static_cast")+                 [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ]+                 [ R.CVar $ R.sname "p" ]+              )+              (R.CApp+                (R.CVar (R.sname tfun_oname))+                (map (tmplArgToCallCExp b) tfun_args)+              )+        TFunOp {..}    ->+          returnCpp b (tfun_ret) $+            R.CBinOp+              R.CArrow+              (R.CTApp+                 (R.sname "static_cast")+                 [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ]+                 [ R.CVar $ R.sname "p" ]+              )+              (R.CApp+                (R.CVar (R.sname ("operator" <> opSymbol tfun_opexp)))+                (map (tmplArgToCallCExp b) (argsFromOpExp tfun_opexp))+              )+++tmplVarToDef ::+     IsCPrimitive+  -> TemplateClass+  -> Variable+  -> Accessor+  -> R.CStatement Identity+tmplVarToDef b t@TmplCls {..} v@(Variable (Arg {..})) a =+    R.CDefinition (Just R.Inline) (tmplFunToDecl b t f) body+  where+    f = tmplAccessorToTFun v a+    typparams = map (R.CTSimple . R.sname) tclass_params+    body =+      case f of+        TFun {..} ->+          let varexp = R.CBinOp+                         R.CArrow+                         (R.CTApp+                           (R.sname "static_cast")+                           [ R.CTStar $ tmplAppTypeFromForm tclass_cxxform typparams ]+                           [ R.CVar $ R.sname "p" ]+                         )+                         (R.CVar (R.sname arg_name))+          in case a of+               Getter -> returnCpp b (tfun_ret) varexp+               Setter -> [ R.CExpSA $+                             R.CBinOp+                               R.CAssign+                               varexp+                               (c2Cxx arg_type (R.CVar (R.sname "value")))+                         ]+        _ -> error "tmplVarToDef: should not happen"++-- Accessor Declaration and Definition++accessorToDecl :: Variable -> Accessor -> R.CFunDecl Identity+accessorToDecl v a =+  let csig = accessorCFunSig (arg_type (unVariable v)) a+      ret = returnCType (cRetType csig)+      fname =+        R.CName [ R.NamePart "Type"+                , R.NamePart (   "_"+                              <> arg_name (unVariable v)+                              <> "_"+                              <> case a of Getter -> "get"; Setter -> "set"+                             )+                ]+      args = argsToCTypVar (cArgTypes csig)+  in R.CFunDecl ret fname args++accessorsToDecls :: [Variable] -> [R.CFunDecl Identity]+accessorsToDecls vs =+  concatMap (\v -> [accessorToDecl v Getter,accessorToDecl v Setter]) vs++accessorToDef :: Variable -> Accessor -> R.CStatement Identity+accessorToDef v a =+  let varexp =+        R.CBinOp+          R.CArrow+          (R.CTApp+            (R.sname "from_nonconst_to_nonconst")+            [ R.CTSimple (R.sname "Type"), R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t"]) ]+            [ R.CVar (R.sname "p") ]+          )+          (R.CVar (R.sname (arg_name (unVariable v))))+      body Getter = R.CReturn $ cxx2C (arg_type (unVariable v)) varexp+      body Setter = R.CExpSA $+                      R.CBinOp+                        R.CAssign+                        varexp+                        (c2Cxx (arg_type (unVariable v)) (R.CVar (R.sname "x")))+  in R.CDefinition Nothing (accessorToDecl v a) [ body a ]+++-- Template Member Function Declaration and Definition++-- TODO: Handle simple type+tmplMemberFunToDecl :: Class -> TemplateMemberFunction -> R.CFunDecl Identity+tmplMemberFunToDecl c f =+  let nsuffix = intersperse (R.NamePart "_") $ map R.NamePart (tmf_params f)+      ret = tmplMemFuncReturnCType c (tmf_ret f)+      fname =+        R.CName (R.NamePart (hsTemplateMemberFunctionName c f <> "_") : nsuffix)+      args = map (tmplMemFuncArgToCTypVar c) ((Arg SelfType "p"):tmf_args f)+  in R.CFunDecl ret fname args++-- TODO: Handle simple type+tmplMemberFunToDef :: Class -> TemplateMemberFunction -> R.CStatement Identity+tmplMemberFunToDef c f =+    R.CDefinition (Just R.Inline) (tmplMemberFunToDecl c f) body+  where+    tparams = map (R.CTSimple . R.sname) (tmf_params f)+    body = returnCpp NonCPrim (tmf_ret f) $+             R.CBinOp+               R.CArrow+               (R.CTApp+                 (R.sname "from_nonconst_to_nonconst")+                 [ R.CTSimple (R.sname (ffiClassName c)), R.CTSimple (R.sname (ffiClassName c <> "_t")) ]+                 [ R.CVar $ R.sname "p" ]+               )+               (R.CTApp+                 (R.sname (tmf_name f))+                 tparams+                 (map (tmplArgToCallCExp NonCPrim) (tmf_args f))+               )

@@ -0,0 +1,37 @@+module FFICXX.Generate.Code.HsCast where++import Language.Haskell.Exts.Build             (app)+import Language.Haskell.Exts.Syntax            (Decl(..),InstDecl(..))+--+import FFICXX.Generate.Name                    (hsClassName,typeclassName)+import FFICXX.Generate.Type.Class              (Class(..),isAbstractClass)+import FFICXX.Generate.Util.HaskellSrcExts     (classA+                                               ,cxEmpty,cxTuple,insDecl+                                               ,mkBind1,mkInstance,mkPVar,mkTVar,mkVar+                                               ,tyapp,tycon,tyPtr+                                               ,unqual)+-----++castBody :: [InstDecl ()]+castBody =+  [ insDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "castPtr") (app (mkVar "get_fptr") (mkVar "x")))) Nothing)+  , insDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "cast_fptr_to_obj") (app (mkVar "castPtr") (mkVar "x")))) Nothing)+  ]++genHsFrontInstCastable :: Class -> Maybe (Decl ())+genHsFrontInstCastable c+  | (not.isAbstractClass) c =+    let iname = typeclassName c+        (_,rname) = hsClassName c+        a = mkTVar "a"+        ctxt = cxTuple [ classA (unqual iname) [a], classA (unqual "FPtr") [a] ]+    in Just (mkInstance ctxt "Castable" [a,tyapp tyPtr (tycon rname)] castBody)+  | otherwise = Nothing++genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())+genHsFrontInstCastableSelf c+  | (not.isAbstractClass) c =+    let (cname,rname) = hsClassName c+    in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)+  | otherwise = Nothing+

@@ -0,0 +1,111 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module FFICXX.Generate.Code.HsFFI where++import Data.Maybe                   ( fromMaybe, mapMaybe )+import Data.Monoid                  ( (<>) )+import Language.Haskell.Exts.Syntax ( Decl(..), ImportDecl(..) )+import System.FilePath              ( (<.>) )+--+import FFICXX.Runtime.CodeGen.Cxx   ( HeaderName(..) )+--+import FFICXX.Generate.Code.Primitive+                                    ( CFunSig(..)+                                    , accessorCFunSig+                                    , genericFuncArgs+                                    , genericFuncRet+                                    , hsFFIFuncTyp+                                    )+import FFICXX.Generate.Dependency   ( class_allparents+                                    , getClassModuleBase+                                    , getTClassModuleBase+                                    )+import FFICXX.Generate.Name         ( aliasedFuncName+                                    , ffiClassName+                                    , hscAccessorName+                                    , hscFuncName+                                    )+import FFICXX.Generate.Type.Class   ( Accessor(Getter,Setter)+                                    , Arg(..)+                                    , Class(..)+                                    , Function(..)+                                    , Selfness(NoSelf,Self)+                                    , TopLevel(..)+                                    , Variable(unVariable)+                                    , isAbstractClass+                                    , isNewFunc+                                    , isStaticFunc+                                    , virtualFuncs+                                    )+import FFICXX.Generate.Type.Module  ( ClassImportHeader(..)+                                    , ClassModule(..)+                                    , TopLevelImportHeader(..)+                                    )+import FFICXX.Generate.Util         ( toLowers )+import FFICXX.Generate.Util.HaskellSrcExts ( mkForImpCcall, mkImport )+++genHsFFI :: ClassImportHeader -> [Decl ()]+genHsFFI header =+  let c = cihClass header+      -- TODO: This C header information should not be necessary according to up-to-date+      --       version of Haskell FFI.+      h = cihSelfHeader header+      -- NOTE: We need to generate FFI both for member functions at the current class level+      --       and parent level. For example, consider a class A with method foo, which a+      --       subclass of B with method bar. Then, A::foo (c_a_foo) and A::bar (c_a_bar)+      --       are made into a FFI function.+      allfns =    concatMap (virtualFuncs . class_funcs)+                            (class_allparents c)+               <> (class_funcs c)++  in    mapMaybe (hsFFIClassFunc h c) allfns+     <> concatMap+          (\v -> [hsFFIAccessor c v Getter, hsFFIAccessor c v Setter])+          (class_vars c)++hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ())+hsFFIClassFunc headerfilename c f =+  if isAbstractClass c+  then Nothing+  else let hfile = unHdrName headerfilename+           -- TODO: Make this a separate function+           cname = ffiClassName c <> "_" <> aliasedFuncName c f+           csig = CFunSig (genericFuncArgs f) (genericFuncRet f)+           typ = if (isNewFunc f || isStaticFunc f)+                 then hsFFIFuncTyp (Just (NoSelf,c)) csig+                 else hsFFIFuncTyp (Just (Self,c)  ) csig+       in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ)+++hsFFIAccessor ::Class -> Variable -> Accessor -> Decl ()+hsFFIAccessor c v a =+  let -- TODO: make this a separate function+      cname = ffiClassName c <> "_" <> arg_name (unVariable v) <> "_" <> (case a of Getter -> "get"; Setter -> "set")+      typ = hsFFIFuncTyp (Just (Self,c)) (accessorCFunSig (arg_type (unVariable  v)) a)+  in mkForImpCcall cname (hscAccessorName c v a) typ+++-- import for FFI++genImportInFFI :: ClassModule -> [ImportDecl ()]+genImportInFFI = map mkMod . cmImportedModulesForFFI+  where mkMod (Left t)  = mkImport (getTClassModuleBase t <.> "Template")+        mkMod (Right c) = mkImport (getClassModuleBase c <.> "RawType")+++----------------------------+-- for top level function --+----------------------------++genTopLevelFFI :: TopLevelImportHeader -> TopLevel -> Decl ()+genTopLevelFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ+  where (fname,args,ret) =+          case tfn of+            TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret)+            TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret)+        hfilename = tihHeaderFileName header <.> "h"+        -- TODO: This must be exposed as a top-level function+        cfname = "c_" <> toLowers fname+        typ =hsFFIFuncTyp Nothing (CFunSig args ret)

@@ -0,0 +1,322 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module FFICXX.Generate.Code.HsFrontEnd where++import Control.Monad.Reader+import Data.Either                             (lefts,rights)+import Data.List+import Data.Monoid                             ((<>))+import Language.Haskell.Exts.Build             (app,letE,name,pApp)+import Language.Haskell.Exts.Syntax            (Decl(..),ExportSpec(..),ImportDecl(..))+import System.FilePath                         ((<.>))+--+import FFICXX.Generate.Code.Primitive          (CFunSig(..),HsFunSig(..)+                                               ,accessorSignature+                                               ,classConstraints+                                               ,convertCpp2HS+                                               ,extractArgRetTypes+                                               ,functionSignature+                                               ,hsFuncXformer+                                               )+import FFICXX.Generate.Name                    (accessorName+                                               ,aliasedFuncName+                                               ,hsClassName+                                               ,hscAccessorName+                                               ,hscFuncName+                                               ,hsFuncName+                                               ,hsFrontNameForTopLevel+                                               ,typeclassName+                                               )+import FFICXX.Generate.Dependency              (class_allparents+                                               ,extractClassDepForTopLevel+                                               ,getClassModuleBase,getTClassModuleBase+                                               ,argumentDependency,returnDependency+                                               )+import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Annotate+import FFICXX.Generate.Type.Module+import FFICXX.Generate.Util+import FFICXX.Generate.Util.HaskellSrcExts+++genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ())+genHsFrontDecl c = do+  -- TODO: revive annotation+  -- for the time being, let's ignore annotation.+  -- amap <- ask+  -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap+  let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body+      sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f)+      body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c+  return cdecl++-------------------++genHsFrontInst :: Class -> Class -> [Decl ()]+genHsFrontInst parent child+  | (not.isAbstractClass) child =+    let idecl = mkInstance cxEmpty (typeclassName parent) [convertCpp2HS (Just child) SelfType] body+        defn f = mkBind1 (hsFuncName child f) [] rhs Nothing+          where rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))+        body = map (insDecl . defn) . virtualFuncs . class_funcs $ parent+    in [idecl]+  | otherwise = []+++++---------------------++genHsFrontInstNew :: Class         -- ^ only concrete class+                  -> Reader AnnotateMap [Decl ()]+genHsFrontInstNew c = do+  -- amap <- ask+  let fs = filter isNewFunc (class_funcs c)+  return . flip concatMap fs $ \f ->+    let+        -- for the time being, let's ignore annotation.+        -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap+        -- newfuncann = mkComment 0 cann+        rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing++genHsFrontInstNonVirtual :: Class -> [Decl ()]+genHsFrontInstNonVirtual c =+  flip concatMap nonvirtualFuncs $ \f ->+    let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing+ where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c)++-----++genHsFrontInstStatic :: Class -> [Decl ()]+genHsFrontInstStatic c =+  flip concatMap (staticFuncs (class_funcs c)) $ \f ->+    let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing++-----++genHsFrontInstVariables :: Class -> [Decl ()]+genHsFrontInstVariables c =+  flip concatMap (class_vars c) $ \v ->+    let rhs accessor =+          app (mkVar (case accessor of Getter -> "xform0"; _ -> "xform1"))+              (mkVar (hscAccessorName c v accessor))+    in    mkFun (accessorName c v Getter) (accessorSignature c v Getter) [] (rhs Getter) Nothing+       <> mkFun (accessorName c v Setter) (accessorSignature c v Setter) [] (rhs Setter) Nothing+++++--------------------------++hsClassRawType :: Class -> [Decl ()]+hsClassRawType c =+  [ mkData    rawname [] [] Nothing+  , mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv+  , mkInstance cxEmpty "FPtr" [hightype]+      [ insType (tyapp (tycon "Raw") hightype) rawtype+      , insDecl (mkBind1 "get_fptr" [pApp (name highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)+      , insDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing)+      ]++  ]+ where (highname,rawname) = hsClassName c+       hightype = tycon highname+       rawtype = tycon rawname+       mderiv = Just (mkDeriving [i_eq,i_ord,i_show])+         where i_eq   = irule Nothing Nothing (ihcon (unqual "Eq"))+               i_ord  = irule Nothing Nothing (ihcon (unqual "Ord"))+               i_show = irule Nothing Nothing (ihcon (unqual "Show"))+++------------+-- upcast --+------------++genHsFrontUpcastClass :: Class -> [Decl ()]+genHsFrontUpcastClass c = mkFun ("upcast"<>highname) typ [mkPVar "h"] rhs Nothing+  where (highname,rawname) = hsClassName c+        hightype = tycon highname+        rawtype = tycon rawname+        iname = typeclassName c+        a_bind = unkindedVar (name "a")+        a_tvar = mkTVar "a"+        typ = tyForall (Just [a_bind])+                (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))+                (tyfun a_tvar hightype)+        rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing+                   , pbind (mkPVarSig "fh2" (tyapp tyPtr rawtype))+                       (app (mkVar "castPtr") (mkVar "fh")) Nothing+                   ]+                   (mkVar "cast_fptr_to_obj" `app` mkVar "fh2")+++--------------+-- downcast --+--------------++genHsFrontDowncastClass :: Class -> [Decl ()]+genHsFrontDowncastClass c = mkFun ("downcast"<>highname) typ [mkPVar "h"] rhs Nothing+  where (highname,_rawname) = hsClassName c+        hightype = tycon highname+        iname = typeclassName c+        a_bind = unkindedVar (name "a")+        a_tvar = mkTVar "a"+        typ = tyForall (Just [a_bind])+                (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))+                (tyfun hightype a_tvar)+        rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing+                   , pbind (mkPVar "fh2") (app (mkVar "castPtr") (mkVar "fh")) Nothing+                   ]+                   (mkVar "cast_fptr_to_obj" `app` mkVar "fh2")+++------------------------+-- Top Level Function --+------------------------+++genTopLevelDef :: TopLevel -> [Decl ()]+genTopLevelDef f@TopLevelFunction {..} =+    let fname = hsFrontNameForTopLevel f+        HsFunSig typs assts =+          extractArgRetTypes+            Nothing+            False+            (CFunSig toplevelfunc_args toplevelfunc_ret)+        sig = tyForall Nothing (Just (cxTuple assts)) (foldr1 tyfun typs)+        xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull"+        cfname = "c_" <> toLowers fname+        rhs = app (mkVar xformerstr) (mkVar cfname)++    in mkFun fname sig [] rhs Nothing+genTopLevelDef v@TopLevelVariable {..} =+    let fname = hsFrontNameForTopLevel v+        cfname = "c_" <> toLowers fname+        rtyp = convertCpp2HS Nothing toplevelvar_ret+        sig = tyapp (tycon "IO") rtyp+        rhs = app (mkVar "xformnull") (mkVar cfname)++    in mkFun fname sig [] rhs Nothing+++------------+-- Export --+------------++genExport :: Class -> [ExportSpec ()]+genExport c =+    let espec n = if null . (filter isVirtualFunc) $ (class_funcs c)+                    then eabs nonamespace (unqual n)+                    else ethingall (unqual n)+    in if isAbstractClass c+       then [ espec (typeclassName c) ]+       else [ ethingall (unqual ((fst.hsClassName) c))+            , espec (typeclassName c)+            , evar (unqual ("upcast" <> (fst.hsClassName) c))+            , evar (unqual ("downcast" <> (fst.hsClassName) c)) ]+            <> genExportConstructorAndNonvirtual c+            <> genExportStatic c++-- | constructor and non-virtual function+genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()]+genExportConstructorAndNonvirtual c = map (evar . unqual) fns+  where fs = class_funcs c+        fns = map (aliasedFuncName c) (constructorFuncs fs+                                       <> nonVirtualNotNewFuncs fs)++-- | staic function export list+genExportStatic :: Class -> [ExportSpec ()]+genExportStatic c = map (evar . unqual) fns+  where fs = class_funcs c+        fns = map (aliasedFuncName c) (staticFuncs fs)+++------------+-- Import --+------------++genExtraImport :: ClassModule -> [ImportDecl ()]+genExtraImport cm = map mkImport (cmExtraImport cm)+++genImportInModule :: Class -> [ImportDecl ()]+genImportInModule x = map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"]+++genImportInInterface :: ClassModule -> [ImportDecl ()]+genImportInInterface m =+  let modlstraw = cmImportedModulesRaw m+      modlstparent = cmImportedModulesHighNonSource m+      modlsthigh = cmImportedModulesHighSource m+  in  [mkImport (cmModule m <.> "RawType")]+      <> flip map modlstraw+           (\case+               Left t -> mkImport (getTClassModuleBase t <.> "Template")+               Right c -> mkImport (getClassModuleBase c <.>"RawType")+           )+      <> flip map modlstparent+           (\case+               Left t -> mkImport (getTClassModuleBase t <.> "Template")+               Right c -> mkImport (getClassModuleBase c <.>"Interface")+           )+      <> flip map modlsthigh+           (\case+               Left t  -> -- TODO: *.Template in the same package needs to have hs-boot.+                          --       Currently, we do not have it yet.+                          mkImport (getTClassModuleBase t <.> "Template")+               Right c -> mkImportSrc (getClassModuleBase c<.>"Interface")+           )++-- |+genImportInCast :: ClassModule -> [ImportDecl ()]+genImportInCast m = [ mkImport (cmModule m <.> "RawType")+                   ,  mkImport (cmModule m <.> "Interface") ]++-- |+genImportInImplementation :: ClassModule -> [ImportDecl ()]+genImportInImplementation m =+  let modlstraw' = cmImportedModulesForFFI m+      modlsthigh = nub $ map Right $ class_allparents $ cihClass $ cmCIH m+      modlstraw = filter (not.(flip elem modlsthigh)) modlstraw'+  in  [ mkImport (cmModule m <.> "RawType")+      , mkImport (cmModule m <.> "FFI")+      , mkImport (cmModule m <.> "Interface")+      , mkImport (cmModule m <.> "Cast") ]+      <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c<.>y)) ["RawType","Cast","Interface"]) modlstraw+      <> concatMap (\case Left t -> [mkImport (getTClassModuleBase t <.> "Template")]; Right c -> map (\y -> mkImport (getClassModuleBase c<.>y)) ["RawType","Cast","Interface"]) modlsthigh+++-- | generate import list for a given top-level function+--   currently this may generate duplicate import list.+-- TODO: eliminate duplicated imports.+genImportForTopLevel :: TopLevel -> [ImportDecl ()]+genImportForTopLevel f =+  let dep4func = extractClassDepForTopLevel f+      ecs = returnDependency dep4func ++ argumentDependency dep4func+      cmods = nub $ map getClassModuleBase $ rights ecs+      tmods = nub $ map getTClassModuleBase $ lefts ecs+  in    concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) cmods+     <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["Template"]) tmods++-- | generate import list for top level module+genImportInTopLevel ::+     String+  -> ([ClassModule],[TemplateClassModule])+  -> TopLevelImportHeader+  -> [ImportDecl ()]+genImportInTopLevel modname (mods,tmods) tih =+  let tfns = tihFuncs tih+  in    map (mkImport . cmModule) mods+     ++ if null tfns+        then []+        else    map mkImport [ "Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast" ]+             ++ map (\c -> mkImport (modname <.> (fst.hsClassName.cihClass) c <.> "RawType")) (tihClassDep tih)+             ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods+             ++ concatMap genImportForTopLevel tfns+

@@ -0,0 +1,37 @@+{-# LANGUAGE OverloadedStrings #-}++module FFICXX.Generate.Code.HsProxy where++import Language.Haskell.Exts.Build    ( app, doE, listE, qualStmt, strE )+import qualified Data.List as L       ( foldr1 )+import Language.Haskell.Exts.Syntax   ( Decl(..) )+--+import qualified FFICXX.Runtime.CodeGen.Cxx as R+import FFICXX.Generate.Util.HaskellSrcExts+                                      ( con, inapp, mkFun, mkVar+                                      , op, qualifier+                                      , tyapp, tycon, tylist+                                      )+++genProxyInstance :: [Decl ()]+genProxyInstance =+    mkFun fname sig [] rhs Nothing+  where fname = "genImplProxy"+        v = mkVar+        sig = tycon "Q" `tyapp` tylist (tycon "Dec")+        rhs = doE [foreignSrcStmt, qualStmt retstmt]+        foreignSrcStmt =+          qualifier $+                  (v "addModFinalizer")+            `app` (      v "addForeignSource"+                   `app` con "LangCxx"+                   `app` (L.foldr1 (\x y -> inapp x (op "++") y)+                            [ includeStatic ]+                         )+                  )+          where+            includeStatic =+              strE $ concatMap (<> "\n")+                [ R.renderCMacro (R.Include "MacroPatternMatch.h") ]+        retstmt = v "pure" `app` listE []

@@ -0,0 +1,440 @@+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}++module FFICXX.Generate.Code.HsTemplate where++import Data.Monoid                    ( (<>) )+import qualified Data.List as L       ( foldr1 )+import Language.Haskell.Exts.Build    ( app, binds, caseE, doE+                                      , lamE, letE, letStmt, listE, name+                                      , pApp, paren, pTuple+                                      , qualStmt, strE, tuple, wildcard+                                      )+import Language.Haskell.Exts.Syntax   ( Boxed(Boxed), Decl(..), ImportDecl(..), Type(TyTuple) )+import System.FilePath                ( (<.>) )+--+import FFICXX.Runtime.CodeGen.Cxx     ( HeaderName(..) )+import qualified FFICXX.Runtime.CodeGen.Cxx as R+import FFICXX.Runtime.TH              ( IsCPrimitive(CPrim,NonCPrim) )+--+import FFICXX.Generate.Code.Cpp       ( genTmplClassCpp+                                      , genTmplFunCpp+                                      , genTmplVarCpp+                                      )+import FFICXX.Generate.Code.Primitive ( functionSignatureT+                                      , functionSignatureTT+                                      , functionSignatureTMF+                                      , tmplAccessorToTFun+                                      )+import FFICXX.Generate.Code.HsCast    ( castBody )+import FFICXX.Generate.Dependency     ( getClassModuleBase+                                      , getTClassModuleBase+                                      , mkModuleDepRaw+                                      , mkModuleDepHighSource+                                      )+import FFICXX.Generate.Name           ( ffiTmplFuncName+                                      , hsTemplateClassName+                                      , hsTemplateMemberFunctionName+                                      , hsTemplateMemberFunctionNameTH+                                      , hsTmplFuncName+                                      , hsTmplFuncNameTH+                                      , tmplAccessorName+                                      , typeclassNameT+                                      )+import FFICXX.Generate.Type.Class     ( Accessor(Getter,Setter)+                                      , Arg(..)+                                      , Class(..)+                                      , TemplateClass(..)+                                      , TemplateFunction(..)+                                      , TemplateMemberFunction(..)+                                      , Variable(..)+                                      , Types(Void)+                                      )+import FFICXX.Generate.Type.Module    ( ClassImportHeader(..)+                                      , TemplateClassImportHeader(..)+                                      )+import FFICXX.Generate.Util.HaskellSrcExts+                                      ( bracketExp+                                      , con, conDecl, cxEmpty, clsDecl+                                      , generator+                                      , inapp, insDecl, insType+                                      , match, mkBind1, mkTBind, mkData, mkNewtype+                                      , mkFun, mkFunSig, mkClass, mkImport, mkInstance+                                      , mkPVar, mkTVar, mkVar+                                      , op, pbind_+                                      , qualConDecl, qualifier+                                      , tyapp, tycon, tyfun, tylist, tyPtr+                                      , typeBracket+                                      )+++------------------------------+-- Template member function --+------------------------------++genTemplateMemberFunctions :: ClassImportHeader -> [Decl ()]+genTemplateMemberFunctions cih =+  let c = cihClass cih+  in concatMap (\f -> genTMFExp c f <> genTMFInstance cih f) (class_tmpl_funcs c)++-- TODO: combine this with genTmplInstance+genTMFExp :: Class -> TemplateMemberFunction -> [Decl ()]+genTMFExp c f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts)+  where+    nh = hsTemplateMemberFunctionNameTH c f+    v = mkVar+    p = mkPVar+    itps = zip ([1..]::[Int]) (tmf_params f)+    tvars = map (\(i,_) -> "typ" ++ show i) itps+    nparams = length itps+    tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type"))+    sig = foldr1 tyfun [tparams , tycon "String", tyapp (tycon "Q") (tycon "Exp") ]+    tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)]+    lit' = strE (hsTemplateMemberFunctionName c f <> "_")+    lam = lamE [p "n"] ( lit' `app` v "<>" `app` v "n")+    rhs = app (v "mkTFunc") $+            let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)]+            in tuple (typs ++ [ v "suffix", lam, v "tyf"])+    sig' = functionSignatureTMF c f+    tassgns = map (\(i,tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps+    bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]+                       (letE tassgns+                          (bracketExp (typeBracket sig')))+                       Nothing+                   ]++genTMFInstance :: ClassImportHeader -> TemplateMemberFunction -> [Decl ()]+genTMFInstance cih f =+    mkFun+      fname+      sig+      [p "isCprim", pTuple [p "qtyp", p "param"]]+      rhs+      Nothing+  where+    c = cihClass cih+    fname = "genInstanceFor_" <> hsTemplateMemberFunctionName c f+    p = mkPVar+    v = mkVar+    sig =         tycon "IsCPrimitive"+          `tyfun` TyTuple () Boxed [tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo"]+          `tyfun` (tycon "Q" `tyapp` tylist (tycon "Dec"))+    rhs = doE [suffixstmt, qtypstmt, genstmt, foreignSrcStmt, letStmt lststmt, qualStmt retstmt]+    suffixstmt = letStmt [ pbind_ (p "suffix") (v "tpinfoSuffix" `app` v "param" ) ]+    qtypstmt = generator (p "typ") (v "qtyp")+    genstmt = generator+                (p "f1")+                (v "mkMember" `app` (     strE (hsTemplateMemberFunctionName c f <> "_")+                                    `app` v "<>"+                                    `app` v "suffix"+                                    )+                              `app` v (hsTemplateMemberFunctionNameTH c f)+                              `app` v "typ"+                              `app` v "suffix"+                )+    lststmt = [ pbind_ (p "lst") (listE ([v "f1"])) ]+    retstmt = v "pure" `app` v "lst"+    -- TODO: refactor out the following code.+    foreignSrcStmt =+      qualifier $+              (v "addModFinalizer")+        `app` (      v "addForeignSource"+               `app` con "LangCxx"+               `app` (L.foldr1 (\x y -> inapp x (op "++") y)+                        [ includeStatic+                        , includeDynamic+                        , namespaceStr+                        , strE (hsTemplateMemberFunctionName c f)+                        , strE "("+                        , v "suffix"+                        , strE ")\n"+                        ]+                     )+              )+      where+        includeStatic =+          strE $ concatMap ((<>"\n") . R.renderCMacro . R.Include) $+               [ HdrName "MacroPatternMatch.h", cihSelfHeader cih ]+            <> cihIncludedHPkgHeadersInCPP cih+            <> cihIncludedCPkgHeaders cih+        includeDynamic =+          letE+            [ pbind_ (p "headers") (v "tpinfoCxxHeaders" `app` v "param" )+            , pbind_ (pApp (name "f") [p "x"])+                (v "renderCMacro" `app` (con "Include" `app` v "x"))+            ]+            (v "concatMap" `app` v "f" `app` v "headers")+        namespaceStr =+          letE+            [ pbind_ (p "nss") (v "tpinfoCxxNamespaces" `app` v "param" )+            , pbind_ (pApp (name "f") [p "x"])+                (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x"))+            ]+            (v "concatMap" `app` v "f" `app` v "nss")++--------------------+-- Template Class --+--------------------++genImportInTemplate :: TemplateClass -> [ImportDecl ()]+genImportInTemplate t0 =+  let+    deps_raw  = mkModuleDepRaw (Left t0)+    deps_high = mkModuleDepHighSource (Left t0)+  in     flip map deps_raw+           (\case+             Left t -> mkImport (getTClassModuleBase t <.> "Template")+             Right c -> mkImport (getClassModuleBase c <.> "RawType")+           )+      <> flip map deps_high+           (\case+             Left t -> mkImport (getTClassModuleBase t <.> "Template")+             Right c -> mkImport (getClassModuleBase c <.> "Interface")+           )++-- |+genTmplInterface :: TemplateClass -> [Decl ()]+genTmplInterface t =+  [ mkData rname (map mkTBind tps) [] Nothing+  , mkNewtype hname (map mkTBind tps)+      [ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing+  , mkClass cxEmpty (typeclassNameT t) (map mkTBind tps) methods+  , mkInstance cxEmpty "FPtr" [ hightype ] fptrbody+  , mkInstance cxEmpty "Castable" [ hightype, tyapp tyPtr rawtype ] castBody+  ]+ where+   (hname,rname) = hsTemplateClassName t+   tps         = tclass_params t+   fs          = tclass_funcs t+   vfs         = tclass_vars t+   rawtype     = foldl1 tyapp (tycon rname : map mkTVar tps)+   hightype    = foldl1 tyapp (tycon hname : map mkTVar tps)+   sigdecl f   = mkFunSig (hsTmplFuncName t f) (functionSignatureT t f)+   sigdeclV vf = let f_g = tmplAccessorToTFun vf Getter+                     f_s = tmplAccessorToTFun vf Setter+                 in [sigdecl f_g, sigdecl f_s]+   methods     = map (clsDecl . sigdecl) fs ++ (map clsDecl . concatMap sigdeclV) vfs++   fptrbody    = [ insType (tyapp (tycon "Raw") hightype) rawtype+                 , insDecl (mkBind1 "get_fptr" [pApp (name hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing )+                 , insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing)+                 ]++-- |+genImportInTH :: TemplateClass -> [ImportDecl ()]+genImportInTH t0 =+  let+    deps_raw  = mkModuleDepRaw (Left t0)+    deps_high = mkModuleDepHighSource (Left t0)+  in     flip concatMap deps_raw+           (\case+             Left t  -> [mkImport (getTClassModuleBase t <.> "Template")]+             Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType","Cast","Interface"]+           )+      <> flip concatMap deps_high+           (\case+             Left t  -> [mkImport (getTClassModuleBase t <.> "Template")]+             Right c -> map (\y -> mkImport (getClassModuleBase c <.> y)) ["RawType","Cast","Interface"]+           )++-- |+genTmplImplementation :: TemplateClass -> [Decl ()]+genTmplImplementation t =+    concatMap gen (tclass_funcs t) ++ concatMap genV (tclass_vars t)+  where+    v = mkVar+    p = mkPVar+    itps = zip ([1..]::[Int]) (tclass_params t)+    tvars = map (\(i,_) -> "typ" ++ show i) itps+    nparams = length itps+    tparams = if nparams == 1 then tycon "Type" else TyTuple () Boxed (replicate nparams (tycon "Type"))+    sig = foldr1 tyfun [tparams , tycon "String", tyapp (tycon "Q") (tycon "Exp") ]+    tvars_p = if nparams == 1 then map p tvars else [pTuple (map p tvars)]+    prefix = tclass_name t++    gen f = mkFun nh sig (tvars_p ++ [p "suffix"]) rhs (Just bstmts)+      where nh = hsTmplFuncNameTH t f+            nc = ffiTmplFuncName f+            lit' = strE (prefix<>"_"<>nc)+            lam = lamE [p "n"] ( lit' `app` v "<>" `app` v "n")+            rhs = app (v "mkTFunc") $+                    let typs = if nparams == 1 then map v tvars else [tuple (map v tvars)]+                    in tuple (typs ++ [ v "suffix", lam, v "tyf"])+            sig' = functionSignatureTT t f+            tassgns = map (\(i,tp) -> pbind_ (p tp) (v "pure" `app` (v ("typ" ++ show i)))) itps+            bstmts = binds [ mkBind1 "tyf" [wildcard] -- [mkPVar "n"]+                               (letE tassgns+                                  (bracketExp (typeBracket sig')))+                               Nothing+                           ]++    genV vf = let f_g = tmplAccessorToTFun vf Getter+                  f_s = tmplAccessorToTFun vf Setter+              in gen f_g ++ gen f_s++-- |+genTmplInstance ::+     TemplateClassImportHeader+  -> [Decl ()]+genTmplInstance tcih =+    mkFun+      fname+      sig+      (p "isCprim" : zipWith (\x y -> pTuple [p x,p y]) qtvars pvars)+      rhs+      Nothing+  where+    t = tcihTClass tcih+    fs = tclass_funcs t+    vfs = tclass_vars t+    tname = tclass_name t+    fname = "gen" <> tname <> "InstanceFor"+    p = mkPVar+    v = mkVar+    itps = zip ([1..]::[Int]) (tclass_params t)+    tvars  = map (\(i,_) -> "typ"   ++ show i) itps+    qtvars = map (\(i,_) -> "qtyp"  ++ show i) itps+    pvars  = map (\(i,_) -> "param" ++ show i) itps+    nparams = length itps+    typs_v   = if nparams == 1 then v (tvars !! 0) else tuple (map v tvars)+    params_l = listE (map v pvars)+    sig = foldr1 tyfun $+               [ tycon "IsCPrimitive" ]+            ++ replicate+                 nparams+                 (TyTuple () Boxed [ tycon "Q" `tyapp` tycon "Type", tycon "TemplateParamInfo" ])+            ++ [ tycon "Q" `tyapp` tylist (tycon "Dec") ]+    nfs = zip ([1..] :: [Int]) fs+    nvfs = zip ([1..] :: [Int]) vfs+    --------------------------+    -- final RHS expression --+    --------------------------+    rhs = doE (   [ paramsstmt, suffixstmt ]+               <> [ generator (p "callmod_") (v "fmap" `app` v "loc_module" `app` (v "location"))+                  , letStmt [ pbind_ (p "callmod")+                                     (v "dot2_" `app` v "callmod_") ]+                  ]+               <> map genqtypstmt (zip tvars qtvars)+               <> map genstmt nfs+               <> concatMap genvarstmt nvfs+               <> [foreignSrcStmt, letStmt lststmt, qualStmt retstmt]+              )+    --------------------------+    paramsstmt = letStmt [ pbind_+                             (p "params")+                             (v "map" `app` (v "tpinfoSuffix") `app` params_l)+                         ]++    suffixstmt = letStmt [ pbind_+                             (p "suffix")+                             (      v "concatMap"+                              `app` (lamE [p "x"] (inapp (strE "_") (op "++") (v "tpinfoSuffix" `app` v "x")))+                              `app` params_l+                             )+                         ]++    genqtypstmt (tvar,qtvar) = generator (p tvar) (v qtvar)+    gen prefix nm f n =+      generator+        (p (prefix<>show n))+        (v nm `app` strE (hsTmplFuncName t f)+              `app` v    (hsTmplFuncNameTH t f)+              `app` typs_v+              `app` v    "suffix"+        )+    genstmt (n,f@TFun    {..}) = gen "f" "mkMember" f n+    genstmt (n,f@TFunNew {..}) = gen "f" "mkNew"    f n+    genstmt (n,f@TFunDelete)   = gen "f" "mkDelete" f n+    genstmt (n,f@TFunOp  {..}) = gen "f" "mkMember" f n+    genvarstmt (n,vf) =+      let+        Variable (Arg {..}) = vf+        f_g = TFun { tfun_ret   = arg_type+                   , tfun_name  = tmplAccessorName vf Getter+                   , tfun_oname = tmplAccessorName vf Getter+                   , tfun_args  = []+                   }+        f_s = TFun { tfun_ret   = Void+                   , tfun_name  = tmplAccessorName vf Setter+                   , tfun_oname = tmplAccessorName vf Setter+                   , tfun_args = [Arg arg_type "value"]+                   }+      in [ gen "vf" "mkMember" f_g (2*n-1)+         , gen "vf" "mkMember" f_s (2*n)+         ]++    lststmt = let mkElems prefix xs = map (v . (\n->prefix<>show n) . fst) xs+              in [ pbind_+                     (p "lst")+                     (listE (   mkElems "f" nfs+                             <> mkElems "vf" (concatMap (\(n,vf) -> [(2*n-1,vf),(2*n,vf)]) nvfs)+                            )+                     )+                 ]++    -- TODO: refactor out the following code.+    foreignSrcStmt =+      qualifier $+              (v "addModFinalizer")+        `app` (      v "addForeignSource"+               `app` con "LangCxx"+               `app` (L.foldr1 (\x y -> inapp x (op "++") y)+                        [ includeStatic+                        , includeDynamic+                        , namespaceStr+                        , strE (tname <> "_instance")+                        , paren $+                            caseE+                              (v "isCprim")+                              [ match (p "CPrim")    (strE "_s")+                              , match (p "NonCPrim") (strE "")+                              ]+                        , strE "("+                        , v "intercalate" `app`+                            strE ", " `app`+                              paren (inapp (v "callmod") (op ":") (v "params"))+                        , strE ")\n"+                        ]+                     )+              )+      where+        -- temporary+        body = map R.renderCMacro $+                    map R.Include (tcihCxxHeaders tcih)+                 ++ map (genTmplFunCpp NonCPrim t) fs+                 ++ map (genTmplFunCpp CPrim    t) fs+                 ++ concatMap (genTmplVarCpp NonCPrim t) vfs+                 ++ concatMap (genTmplVarCpp CPrim    t) vfs+                 ++ [ genTmplClassCpp NonCPrim t (fs,vfs)+                    , genTmplClassCpp CPrim    t (fs,vfs)+                    ]+        includeStatic =+          strE $ concatMap (<> "\n")+                   (   [ R.renderCMacro (R.Include (HdrName "MacroPatternMatch.h")) ]+                    ++ body+                   )+        cxxHeaders    = v "concatMap" `app` (v "tpinfoCxxHeaders") `app` params_l+        cxxNamespaces = v "concatMap" `app` (v "tpinfoCxxNamespaces") `app` params_l+        includeDynamic =+          letE+            [ pbind_ (p "headers") cxxHeaders+            , pbind_ (pApp (name "f") [p "x"])+                    (v "renderCMacro" `app` (con "Include" `app` v "x"))+            ]+            (v "concatMap" `app` v "f" `app` v "headers")+        namespaceStr =+          letE+            [ pbind_ (p "nss") cxxNamespaces+            , pbind_ (pApp (name "f") [p "x"])+                (v "renderCStmt" `app` (con "UsingNamespace" `app` v "x"))+            ]+            (v "concatMap" `app` v "f" `app` v "nss")++    retstmt = v "pure"+              `app` listE [ v "mkInstance"+                            `app` listE []+                            `app` foldl1+                                    (\f x -> con "AppT" `app` f `app` x)+                                    (v "con" `app` strE (typeclassNameT t) : map v tvars)+                            `app` (v "lst")+                          ]

@@ -0,0 +1,1006 @@+{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE RecordWildCards #-}++module FFICXX.Generate.Code.Primitive where++import Control.Monad.Trans.State    ( runState, put, get )+import Data.Functor.Identity        ( Identity )+import Data.Monoid                  ( (<>) )+import Language.Haskell.Exts.Syntax ( Asst(..), Context, Type(..) )+--+import qualified FFICXX.Runtime.CodeGen.Cxx as R+import FFICXX.Runtime.TH            ( IsCPrimitive(CPrim,NonCPrim) )+--+import FFICXX.Generate.Name         ( ffiClassName+                                    , hsClassName+                                    , hsClassNameForTArg+                                    , hsTemplateClassName+                                    , tmplAccessorName+                                    , typeclassName+                                    , typeclassNameFromStr+                                    )+import FFICXX.Generate.Type.Class   ( Accessor(Getter,Setter)+                                    , Arg(..)+                                    , Class(..)+                                    , CPPTypes(..)+                                    , CTypes(..)+                                    , Form(..)+                                    , Function(..)+                                    , IsConst(Const,NoConst)+                                    , Selfness(NoSelf,Self)+                                    , TemplateAppInfo(..)+                                    , TemplateArgType(TArg_TypeParam)+                                    , TemplateClass(..)+                                    , TemplateFunction(..)+                                    , TemplateMemberFunction(..)+                                    , Types(..)+                                    , Variable(..)+                                    , argsFromOpExp+                                    , isNonVirtualFunc+                                    , isVirtualFunc+                                    )+import FFICXX.Generate.Util.HaskellSrcExts+       ( classA, cxTuple, mkTVar, mkVar, parenSplice, tyapp, tycon, tyfun, tyPtr, tySplice+       , unit_tycon, unqual )+++data CFunSig = CFunSig { cArgTypes :: [Arg]+                       , cRetType :: Types+                       }++data HsFunSig = HsFunSig { hsSigTypes :: [Type ()]+                         , hsSigConstraints :: [Asst ()]+                         }++ctypToCType :: CTypes -> IsConst -> R.CType Identity+ctypToCType ctyp isconst =+  let typ = case ctyp of+        CTBool      -> R.CTSimple $ R.sname "bool"+        CTChar      -> R.CTSimple $ R.sname "char"+        CTClock     -> R.CTSimple $ R.sname "clock_t"+        CTDouble    -> R.CTSimple $ R.sname "double"+        CTFile      -> R.CTSimple $ R.sname "FILE"+        CTFloat     -> R.CTSimple $ R.sname "float"+        CTFpos      -> R.CTSimple $ R.sname "fpos_t"+        CTInt       -> R.CTSimple $ R.sname "int"+        CTIntMax    -> R.CTSimple $ R.sname "intmax_t"+        CTIntPtr    -> R.CTSimple $ R.sname "intptr_t"+        CTJmpBuf    -> R.CTSimple $ R.sname "jmp_buf"+        CTLLong     -> R.CTSimple $ R.sname "long long"+        CTLong      -> R.CTSimple $ R.sname "long"+        CTPtrdiff   -> R.CTSimple $ R.sname "ptrdiff_t"+        CTSChar     -> R.CTSimple $ R.sname "sized char"+        CTSUSeconds -> R.CTSimple $ R.sname "suseconds_t"+        CTShort     -> R.CTSimple $ R.sname "short"+        CTSigAtomic -> R.CTSimple $ R.sname "sig_atomic_t"+        CTSize      -> R.CTSimple $ R.sname "size_t"+        CTTime      -> R.CTSimple $ R.sname "time_t"+        CTUChar     -> R.CTSimple $ R.sname "unsigned char"+        CTUInt      -> R.CTSimple $ R.sname "unsigned int"+        CTUIntMax   -> R.CTSimple $ R.sname "uintmax_t"+        CTUIntPtr   -> R.CTSimple $ R.sname "uintptr_t"+        CTULLong    -> R.CTSimple $ R.sname "unsigned long long"+        CTULong     -> R.CTSimple $ R.sname "unsigned long"+        CTUSeconds  -> R.CTSimple $ R.sname "useconds_t"+        CTUShort    -> R.CTSimple $ R.sname "unsigned short"+        CTWchar     -> R.CTSimple $ R.sname "wchar_t"+        CTInt8      -> R.CTSimple $ R.sname "int8_t"+        CTInt16     -> R.CTSimple $ R.sname "int16_t"+        CTInt32     -> R.CTSimple $ R.sname "int32_t"+        CTInt64     -> R.CTSimple $ R.sname "int64_t"+        CTUInt8     -> R.CTSimple $ R.sname "uint8_t"+        CTUInt16    -> R.CTSimple $ R.sname "uint16_t"+        CTUInt32    -> R.CTSimple $ R.sname "uint32_t"+        CTUInt64    -> R.CTSimple $ R.sname "uint64_t"+        CTString    -> R.CTStar $ R.CTSimple $ R.sname "char"+        CTVoidStar  -> R.CTStar R.CTVoid+        CEnum _ type_str -> R.CTVerbatim type_str+        CPointer s  -> R.CTStar (ctypToCType s NoConst)+        CRef s      -> R.CTStar (ctypToCType s NoConst)+  in case isconst of+       Const   -> R.CTConst typ+       NoConst -> typ++self_ :: Types+self_ = SelfType++cstring_ :: Types+cstring_ = CT CTString Const++cint_ :: Types+cint_    = CT CTInt    Const++int_ :: Types+int_     = CT CTInt    NoConst++uint_ :: Types+uint_ = CT CTUInt NoConst++ulong_ :: Types+ulong_ = CT CTULong NoConst++long_ :: Types+long_ = CT CTLong NoConst++culong_ :: Types+culong_ = CT CTULong Const++clong_ :: Types+clong_ = CT CTLong Const++cchar_ :: Types+cchar_ = CT CTChar Const++char_ :: Types+char_ = CT CTChar NoConst++cshort_ :: Types+cshort_ = CT CTShort Const++short_ :: Types+short_ = CT CTShort NoConst++cdouble_ :: Types+cdouble_ = CT CTDouble Const++double_ :: Types+double_  = CT CTDouble NoConst++doublep_ :: Types+doublep_ = CT (CPointer CTDouble) NoConst++cfloat_ :: Types+cfloat_ = CT CTFloat Const++float_ :: Types+float_ = CT CTFloat NoConst++bool_ :: Types+bool_    = CT CTBool   NoConst++void_ :: Types+void_ = Void++voidp_ :: Types+voidp_ = CT CTVoidStar NoConst++intp_ :: Types+intp_ = CT (CPointer CTInt) NoConst++intref_ :: Types+intref_ = CT (CRef CTInt) NoConst+++charpp_ :: Types+charpp_ = CT (CPointer CTString) NoConst++ref_ :: CTypes -> Types+ref_ t = CT (CRef t) NoConst++star_ :: CTypes -> Types+star_ t = CT (CPointer t) NoConst++cstar_ :: CTypes -> Types+cstar_ t = CT (CPointer t) Const++self :: String -> Arg+self var = Arg self_ var++voidp :: String -> Arg+voidp var = Arg voidp_ var++cstring :: String -> Arg+cstring var = Arg cstring_ var++cint :: String -> Arg+cint var = Arg cint_ var++int :: String -> Arg+int var = Arg int_ var++uint :: String -> Arg+uint var = Arg uint_ var++long :: String -> Arg+long var = Arg long_ var++ulong :: String -> Arg+ulong var = Arg ulong_ var++clong :: String -> Arg+clong var = Arg clong_ var++culong :: String -> Arg+culong var = Arg culong_ var++cchar :: String -> Arg+cchar var = Arg cchar_ var++char :: String -> Arg+char var = Arg char_ var++cshort :: String -> Arg+cshort var = Arg cshort_ var++short :: String -> Arg+short var = Arg short_ var++cdouble :: String -> Arg+cdouble var = Arg cdouble_ var++double :: String -> Arg+double  var = Arg double_ var++doublep :: String -> Arg+doublep var = Arg doublep_ var++cfloat :: String -> Arg+cfloat var = Arg float_ var++float :: String -> Arg+float var = Arg float_ var++bool :: String -> Arg+bool var = Arg bool_ var++intp :: String -> Arg+intp var = Arg intp_ var++intref :: String -> Arg+intref var = Arg intref_ var++charpp :: String -> Arg+charpp var = Arg charpp_ var++ref :: CTypes -> String -> Arg+ref t var = Arg (ref_ t) var++star :: CTypes -> String -> Arg+star t var = Arg (star_ t) var++cstar :: CTypes -> String -> Arg+cstar t var = Arg (cstar_ t) var+++cppclass_ :: Class -> Types+cppclass_ c =  CPT (CPTClass c) NoConst++cppclass :: Class -> String -> Arg+cppclass c vname = Arg (cppclass_ c) vname++++cppclassconst :: Class -> String -> Arg+cppclassconst c vname = Arg (CPT (CPTClass c) Const) vname++cppclassref_ :: Class -> Types+cppclassref_ c = CPT (CPTClassRef c) NoConst++cppclassref :: Class -> String -> Arg+cppclassref c vname = Arg (cppclassref_ c) vname++cppclasscopy_ :: Class -> Types+cppclasscopy_ c = CPT (CPTClassCopy c) NoConst++cppclasscopy :: Class -> String -> Arg+cppclasscopy c vname = Arg (cppclasscopy_ c) vname++cppclassmove_ :: Class -> Types+cppclassmove_ c = CPT (CPTClassMove c) NoConst++cppclassmove :: Class -> String -> Arg+cppclassmove c vname = Arg (cppclassmove_ c) vname+++argToCTypVar :: Arg -> (R.CType Identity, R.CName Identity)+argToCTypVar (Arg (CT ctyp isconst) varname) =+  (ctypToCType ctyp isconst, R.sname varname)+argToCTypVar (Arg SelfType varname) =+  (R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_p" ]), R.sname varname)+argToCTypVar (Arg (CPT (CPTClass c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname)+  where cname = ffiClassName c+argToCTypVar (Arg (CPT (CPTClassRef c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname)+  where cname = ffiClassName c+argToCTypVar (Arg (CPT (CPTClassCopy c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname)+  where cname = ffiClassName c+argToCTypVar (Arg (CPT (CPTClassMove c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> cname <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (cname <> "_p")), R.sname varname)+  where cname = ffiClassName c+argToCTypVar (Arg (TemplateApp     _) varname) = (R.CTStar R.CTVoid, R.sname varname)+argToCTypVar (Arg (TemplateAppRef  _) varname) = (R.CTStar R.CTVoid, R.sname varname)+argToCTypVar (Arg (TemplateAppMove _) varname) = (R.CTStar R.CTVoid, R.sname varname)+argToCTypVar t = error ("argToCTypVar: " <> show t)++argsToCTypVar :: [Arg] -> [ (R.CType Identity, R.CName Identity) ]+argsToCTypVar args =+  let args' = (Arg SelfType "p") : args+  in map argToCTypVar args'++argsToCTypVarNoSelf :: [Arg] -> [ (R.CType Identity, R.CName Identity) ]+argsToCTypVarNoSelf = map argToCTypVar++argToCallCExp :: Arg -> R.CExp Identity+argToCallCExp (Arg t e) = c2Cxx t (R.CVar (R.sname e))+++-- TODO: rename this function by castExpressionFrom/To or something like that.+returnCType :: Types -> R.CType Identity+returnCType (CT ctyp isconst)        = ctypToCType ctyp isconst+returnCType Void                     = R.CTVoid+returnCType SelfType                 = R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_p" ])+returnCType (CPT (CPTClass c) _)     = R.CTSimple (R.sname (ffiClassName c <> "_p"))+returnCType (CPT (CPTClassRef c) _)  = R.CTSimple (R.sname (ffiClassName c <> "_p"))+returnCType (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p"))+returnCType (CPT (CPTClassMove c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p"))+returnCType (TemplateApp     _)      = R.CTStar R.CTVoid+returnCType (TemplateAppRef  _)      = R.CTStar R.CTVoid+returnCType (TemplateAppMove _)      = R.CTStar R.CTVoid+returnCType (TemplateType _)         = R.CTStar R.CTVoid+returnCType (TemplateParam t)        = R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ])+returnCType (TemplateParamPointer t) = R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ])++-- TODO: Rewrite this with static_cast+c2Cxx :: Types -> R.CExp Identity -> R.CExp Identity+c2Cxx t e =+  case t of+    CT  (CRef _)         _ -> R.CStar e+    CPT (CPTClass     c) _ -> R.CTApp+                                (R.sname "from_nonconst_to_nonconst")+                                [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ]+                                [ e ]+                              where f = ffiClassName c+    CPT (CPTClassRef  c) _ -> R.CTApp+                                (R.sname "from_nonconstref_to_nonconstref")+                                [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ]+                                [ R.CStar e ]+                              where f = ffiClassName c+    CPT (CPTClassCopy c) _ -> R.CStar $+                                R.CTApp+                                  (R.sname "from_nonconst_to_nonconst")+                                  [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ]+                                  [ e ]+                              where f = ffiClassName c+    CPT (CPTClassMove c) _ -> R.CApp+                                (R.CVar (R.sname "std::move"))+                                [ R.CTApp+                                    (R.sname "from_nonconstref_to_nonconstref")+                                    [ R.CTSimple (R.sname f), R.CTSimple (R.sname (f <> "_t")) ]+                                    [ R.CStar e ]+                                ]+                              where f = ffiClassName c+    TemplateApp    p       -> R.CTApp+                                (R.sname "from_nonconstref_to_nonconst")+                                [ R.CTVerbatim (tapp_CppTypeForParam p), R.CTVoid ]+                                [ e ]+    TemplateAppRef p       -> R.CStar $+                                R.CCast (R.CTStar (R.CTVerbatim (tapp_CppTypeForParam p))) e+    TemplateAppMove p      -> R.CApp+                                (R.CVar (R.sname "std::move"))+                                [ R.CStar $+                                    R.CCast (R.CTStar (R.CTVerbatim (tapp_CppTypeForParam p))) e+                                ]+    _                      -> e++-- TODO: Rewrite this with static_cast+--       Merge this with returnCpp after Void and simple type adjustment+-- TODO: Resolve all the error cases+cxx2C :: Types -> R.CExp Identity -> R.CExp Identity+cxx2C t e =+  case t of+    Void -> R.CNull+    SelfType ->+      R.CTApp+        (R.sname "from_nonconst_to_nonconst")+        [ R.CTSimple (R.CName [ R.NamePart "Type", R.NamePart "_t"]), R.CTSimple (R.sname "Type") ]+        [ R.CCast (R.CTStar (R.CTSimple (R.sname "Type"))) e ]+      -- "to_nonconst<Type ## _t, Type>((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<void*>(r));"+    TemplateAppRef _ ->+      error "cxx2C: TemplateAppRef"+                              -- g <> "* r = new " <> g <> "(" <> e <> "); "+                              -- <> "return (static_cast<void*>(r));"+    TemplateAppMove _ ->+      error "cxx2C: TemplateAppMove"+    TemplateType _ ->+      error "cxx2C: TemplateType"+    TemplateParam _ ->+      error "cxx2C: TemplateParam"+                              -- if b then e+                              --      else "to_nonconst<Type ## _t, Type>((Type *)&(" <> e <> "))"+    TemplateParamPointer _ ->+      error "cxx2C: TemplateParamPointer"+                              -- if b then "(" <> callstr <> ");"+                              --      else "to_nonconst<Type ## _t, Type>(" <> e <> ") ;"++tmplAppTypeFromForm :: Form -> [R.CType Identity] -> R.CType Identity+tmplAppTypeFromForm (FormSimple tclass) targs = R.CTTApp (R.sname tclass) targs+tmplAppTypeFromForm (FormNested tclass inner) targs = R.CTScoped (R.CTTApp (R.sname tclass) targs) (R.CTVerbatim inner)++tmplArgToCTypVar ::+     IsCPrimitive+  -> TemplateClass+  -> Arg+  -> (R.CType Identity, R.CName Identity)+tmplArgToCTypVar _ _  (Arg (CT ctyp isconst) varname) =+  (ctypToCType ctyp isconst, R.sname varname)+tmplArgToCTypVar _ _ (Arg SelfType varname) =+  (R.CTStar R.CTVoid, R.sname varname)+tmplArgToCTypVar _ _ (Arg (CPT (CPTClass c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplArgToCTypVar _ _ (Arg (CPT (CPTClassRef c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplArgToCTypVar _ _ (Arg (CPT (CPTClassMove c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplArgToCTypVar _ _ (Arg (TemplateApp     _) v) = (R.CTStar R.CTVoid, R.sname v)+tmplArgToCTypVar _ _ (Arg (TemplateAppRef  _) v) = (R.CTStar R.CTVoid, R.sname v)+tmplArgToCTypVar _ _ (Arg (TemplateAppMove _) v) = (R.CTStar R.CTVoid, R.sname v)+tmplArgToCTypVar _ _ (Arg (TemplateType    _) v) = (R.CTStar R.CTVoid, R.sname v)+tmplArgToCTypVar CPrim    _ (Arg (TemplateParam t) v) = (R.CTSimple (R.sname t), R.sname v)+tmplArgToCTypVar NonCPrim _ (Arg (TemplateParam t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]), R.sname v)+tmplArgToCTypVar CPrim    _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.sname t), R.sname v)+tmplArgToCTypVar NonCPrim _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p"]), R.sname v)+tmplArgToCTypVar _ _ _ = error "tmplArgToCTypVar: undefined"++tmplAllArgsToCTypVar ::+     IsCPrimitive+  -> Selfness+  -> TemplateClass+  -> [Arg]+  -> [ (R.CType Identity, R.CName Identity) ]+tmplAllArgsToCTypVar b s t args =+  let args' = case s of+                Self   -> (Arg (TemplateType t) "p") : args+                NoSelf -> args+  in map (tmplArgToCTypVar b t) args'++-- TODO: Rewrite this with static_cast.+--       Implement missing cases.+tmplArgToCallCExp+  :: IsCPrimitive+  -> Arg+  -> R.CExp Identity+tmplArgToCallCExp _ (Arg (CPT (CPTClass c) _) varname) =+  R.CTApp+    (R.sname "from_nonconst_to_nonconst")+    [ R.CTSimple (R.sname str), R.CTSimple (R.sname (str <> "_t")) ]+    [ R.CVar (R.sname varname) ]+  where str = ffiClassName c+tmplArgToCallCExp _ (Arg (CPT (CPTClassRef c) _) varname) =+  R.CTApp+    (R.sname "from_nonconstref_to_nonconstref")+    [ R.CTSimple (R.sname str), R.CTSimple (R.sname (str <> "_t")) ]+    [ R.CStar $ R.CVar $ R.sname varname ]+  where str = ffiClassName c+tmplArgToCallCExp _ (Arg (CPT (CPTClassMove c) _) varname) =+  R.CApp+    (R.CVar (R.sname "std::move"))+    [R.CTApp+      (R.sname "from_nonconstref_to_nonconstref")+      [ R.CTSimple (R.sname str), R.CTSimple (R.sname (str <> "_t")) ]+      [ R.CStar $ R.CVar $ R.sname varname ]+    ]+  where str = ffiClassName c+tmplArgToCallCExp _ (Arg (CT (CRef _) _) varname) =+  R.CStar $ R.CVar $ R.sname varname+tmplArgToCallCExp _ (Arg (TemplateApp x) varname) =+  let targs = map (R.CTSimple . R.sname . hsClassNameForTArg) (tapp_tparams x)+  in R.CTApp+       (R.sname "static_cast")+       [ R.CTStar $ tmplAppTypeFromForm (tclass_cxxform (tapp_tclass x)) targs ]+       [ R.CVar $ R.sname varname ]+tmplArgToCallCExp _ (Arg (TemplateAppRef x) varname) =+  let targs = map (R.CTSimple . R.sname . hsClassNameForTArg) (tapp_tparams x)+  in R.CStar $+       R.CTApp+         (R.sname "static_cast")+         [ R.CTStar $ tmplAppTypeFromForm (tclass_cxxform (tapp_tclass x)) targs ]+         [ R.CVar $ R.sname varname ]+tmplArgToCallCExp _ (Arg (TemplateAppMove x) varname) =+  let targs = map (R.CTSimple . R.sname . hsClassNameForTArg) (tapp_tparams x)+  in R.CApp+       (R.CVar (R.sname "std::move"))+       [ R.CStar $+           R.CTApp+             (R.sname "static_cast")+             [ R.CTStar $ tmplAppTypeFromForm (tclass_cxxform (tapp_tclass x)) targs ]+             [ R.CVar $ R.sname varname ]+       ]+tmplArgToCallCExp b (Arg (TemplateParam typ) varname) =+  case b of+    CPrim    -> R.CVar $ R.sname varname+    NonCPrim -> R.CStar $+                  R.CTApp+                    (R.sname "from_nonconst_to_nonconst")+                    [ R.CTSimple (R.sname typ), R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t"]) ]+                    [ R.CVar $ R.sname varname ]+tmplArgToCallCExp b (Arg (TemplateParamPointer typ) varname) =+  case b of+    CPrim    -> R.CVar $ R.sname varname+    NonCPrim -> R.CTApp+                  (R.sname "from_nonconst_to_nonconst")+                  [ R.CTSimple (R.sname typ), R.CTSimple (R.CName [ R.NamePart typ, R.NamePart "_t"]) ]+                  [ R.CVar $ R.sname varname ]+tmplArgToCallCExp _ (Arg _ varname) = R.CVar $ R.sname varname++tmplReturnCType ::+     IsCPrimitive+  -> Types+  -> R.CType Identity+tmplReturnCType _ (CT ctyp isconst)        = ctypToCType ctyp isconst+tmplReturnCType _ Void                     = R.CTVoid+tmplReturnCType _ SelfType                 = R.CTStar R.CTVoid+tmplReturnCType _ (CPT (CPTClass c) _)     = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplReturnCType _ (CPT (CPTClassRef c) _)  = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplReturnCType _ (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplReturnCType _ (CPT (CPTClassMove c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplReturnCType _ (TemplateApp     _)      = R.CTStar R.CTVoid+tmplReturnCType _ (TemplateAppRef  _)      = R.CTStar R.CTVoid+tmplReturnCType _ (TemplateAppMove _)      = R.CTStar R.CTVoid+tmplReturnCType _ (TemplateType _)         = R.CTStar R.CTVoid+tmplReturnCType b (TemplateParam t)        = case b of+                                                   CPrim    -> R.CTSimple $ R.sname t+                                                   NonCPrim -> R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ]+tmplReturnCType b (TemplateParamPointer t) = case b of+                                                   CPrim    -> R.CTSimple $ R.sname t+                                                   NonCPrim -> R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ]++-- ---------------------------+-- Template Member Function --+-- ---------------------------++-- |+tmplMemFuncArgToCTypVar :: Class -> Arg -> (R.CType Identity, R.CName Identity)+tmplMemFuncArgToCTypVar _ (Arg (CT ctyp isconst) varname) =+  (ctypToCType ctyp isconst, R.sname varname)+tmplMemFuncArgToCTypVar c (Arg SelfType varname) =+  (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClass c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClassRef c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplMemFuncArgToCTypVar _ (Arg (CPT (CPTClassMove c) isconst) varname) =+  case isconst of+    Const   -> (R.CTSimple (R.sname ("const_" <> ffiClassName c <> "_p")), R.sname varname)+    NoConst -> (R.CTSimple (R.sname (ffiClassName c <> "_p")), R.sname varname)+tmplMemFuncArgToCTypVar _ (Arg (TemplateApp     _) v)      = (R.CTStar R.CTVoid, R.sname v)+tmplMemFuncArgToCTypVar _ (Arg (TemplateAppRef  _) v)      = (R.CTStar R.CTVoid, R.sname v)+tmplMemFuncArgToCTypVar _ (Arg (TemplateAppMove _) v)      = (R.CTStar R.CTVoid, R.sname v)+tmplMemFuncArgToCTypVar _ (Arg (TemplateType   _)  v)      = (R.CTStar R.CTVoid, R.sname v)+tmplMemFuncArgToCTypVar _ (Arg (TemplateParam t) v)        = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]), R.sname v)+tmplMemFuncArgToCTypVar _ (Arg (TemplateParamPointer t) v) = (R.CTSimple (R.CName [ R.NamePart t, R.NamePart "_p" ]), R.sname v)+tmplMemFuncArgToCTypVar _ _ = error "tmplMemFuncArgToString: undefined"+++-- |+tmplMemFuncReturnCType :: Class -> Types -> R.CType Identity+tmplMemFuncReturnCType _ (CT ctyp isconst)        = ctypToCType ctyp isconst+tmplMemFuncReturnCType _ Void                     = R.CTVoid+tmplMemFuncReturnCType c SelfType                 = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplMemFuncReturnCType _ (CPT (CPTClass c) _)     = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplMemFuncReturnCType _ (CPT (CPTClassRef c) _)  = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplMemFuncReturnCType _ (CPT (CPTClassCopy c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplMemFuncReturnCType _ (CPT (CPTClassMove c) _) = R.CTSimple (R.sname (ffiClassName c <> "_p"))+tmplMemFuncReturnCType _ (TemplateApp     _)      = R.CTStar R.CTVoid+tmplMemFuncReturnCType _ (TemplateAppRef  _)      = R.CTStar R.CTVoid+tmplMemFuncReturnCType _ (TemplateAppMove _)      = R.CTStar R.CTVoid+tmplMemFuncReturnCType _ (TemplateType _)         = R.CTStar R.CTVoid+tmplMemFuncReturnCType _ (TemplateParam t)        = R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ]+tmplMemFuncReturnCType _ (TemplateParamPointer t) = R.CTSimple $ R.CName [ R.NamePart t, R.NamePart "_p" ]++-- |+convertC2HS :: CTypes -> Type ()+convertC2HS CTBool        = tycon "CBool"+convertC2HS CTChar        = tycon "CChar"+convertC2HS CTClock       = tycon "CClock"+convertC2HS CTDouble      = tycon "CDouble"+convertC2HS CTFile        = tycon "CFile"+convertC2HS CTFloat       = tycon "CFloat"+convertC2HS CTFpos        = tycon "CFpos"+convertC2HS CTInt         = tycon "CInt"+convertC2HS CTIntMax      = tycon "CIntMax"+convertC2HS CTIntPtr      = tycon "CIntPtr"+convertC2HS CTJmpBuf      = tycon "CJmpBuf"+convertC2HS CTLLong       = tycon "CLLong"+convertC2HS CTLong        = tycon "CLong"+convertC2HS CTPtrdiff     = tycon "CPtrdiff"+convertC2HS CTSChar       = tycon "CSChar"+convertC2HS CTSUSeconds   = tycon "CSUSeconds"+convertC2HS CTShort       = tycon "CShort"+convertC2HS CTSigAtomic   = tycon "CSigAtomic"+convertC2HS CTSize        = tycon "CSize"+convertC2HS CTTime        = tycon "CTime"+convertC2HS CTUChar       = tycon "CUChar"+convertC2HS CTUInt        = tycon "CUInt"+convertC2HS CTUIntMax     = tycon "CUIntMax"+convertC2HS CTUIntPtr     = tycon "CUIntPtr"+convertC2HS CTULLong      = tycon "CULLong"+convertC2HS CTULong       = tycon "CULong"+convertC2HS CTUSeconds    = tycon "CUSeconds"+convertC2HS CTUShort      = tycon "CUShort"+convertC2HS CTWchar       = tycon "CWchar"+convertC2HS CTInt8        = tycon "Int8"+convertC2HS CTInt16       = tycon "Int16"+convertC2HS CTInt32       = tycon "Int32"+convertC2HS CTInt64       = tycon "Int64"+convertC2HS CTUInt8       = tycon "Word8"+convertC2HS CTUInt16      = tycon "Word16"+convertC2HS CTUInt32      = tycon "Word32"+convertC2HS CTUInt64      = tycon "Word64"+convertC2HS CTString      = tycon "CString"+convertC2HS CTVoidStar    = tyapp (tycon "Ptr") unit_tycon+convertC2HS (CEnum t _)   = convertC2HS t+convertC2HS (CPointer t)  = tyapp (tycon "Ptr") (convertC2HS t)+convertC2HS (CRef t)      = tyapp (tycon "Ptr") (convertC2HS t)++-- |+convertCpp2HS :: Maybe Class -> Types -> Type ()+convertCpp2HS _c Void                      = unit_tycon+convertCpp2HS (Just c) SelfType            = tycon ((fst.hsClassName) c)+convertCpp2HS Nothing SelfType             = error "convertCpp2HS : SelfType but no class "+convertCpp2HS _c (CT t _)                  = convertC2HS t+convertCpp2HS _c (CPT (CPTClass c') _)     = (tycon . fst . hsClassName) c'+convertCpp2HS _c (CPT (CPTClassRef c') _)  = (tycon . fst . hsClassName) c'+convertCpp2HS _c (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c'+convertCpp2HS _c (CPT (CPTClassMove c') _) = (tycon . fst . hsClassName) c'+convertCpp2HS _c (TemplateApp x) =+  foldl1 tyapp $ map tycon $+    tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x)+convertCpp2HS _c (TemplateAppRef x) =+  foldl1 tyapp $ map tycon $+    tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x)+convertCpp2HS _c (TemplateAppMove x) =+  foldl1 tyapp $ map tycon $+    tclass_name (tapp_tclass x) : map hsClassNameForTArg (tapp_tparams x)+convertCpp2HS _c (TemplateType t) =+  foldl1 tyapp $+    tycon (tclass_name t) : map mkTVar (tclass_params t)+convertCpp2HS _c (TemplateParam p)         = mkTVar p+convertCpp2HS _c (TemplateParamPointer p)  = mkTVar p++-- |+convertCpp2HS4Tmpl+  :: Type ()    -- ^ self+  -> Maybe Class+  -> [Type ()]    -- ^ type paramemter splice+  -> Types+  -> Type ()+convertCpp2HS4Tmpl _ c _ Void                          = convertCpp2HS c Void+convertCpp2HS4Tmpl _ (Just c) _ SelfType               = convertCpp2HS (Just c) SelfType+convertCpp2HS4Tmpl _ Nothing _ SelfType                = convertCpp2HS Nothing SelfType+convertCpp2HS4Tmpl _ c _ x@(CT _ _)                    = convertCpp2HS c x+convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClass _) _)        = convertCpp2HS c x+convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassRef _) _)     = convertCpp2HS c x+convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassCopy _) _)    = convertCpp2HS c x+convertCpp2HS4Tmpl _ c _ x@(CPT (CPTClassMove _) _)    = convertCpp2HS c x+convertCpp2HS4Tmpl _ _ ss (TemplateApp info) =+  let pss = zip (tapp_tparams info) ss+  in foldl1 tyapp $+       tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _,s) -> s; (p,_) -> tycon (hsClassNameForTArg p)) pss+convertCpp2HS4Tmpl _ _ ss (TemplateAppRef info) =+  let pss = zip (tapp_tparams info) ss+  in foldl1 tyapp $+       tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _,s) -> s; (p,_) -> tycon (hsClassNameForTArg p)) pss+convertCpp2HS4Tmpl _ _ ss (TemplateAppMove info) =+  let pss = zip (tapp_tparams info) ss+  in foldl1 tyapp $+       tycon (tclass_name (tapp_tclass info)) : map (\case (TArg_TypeParam _,s) -> s; (p,_) -> tycon (hsClassNameForTArg p)) pss+convertCpp2HS4Tmpl e _ _ (TemplateType _)         = e+convertCpp2HS4Tmpl _ _ _ (TemplateParam p)        = tySplice . parenSplice . mkVar $ p+convertCpp2HS4Tmpl _ _ _ (TemplateParamPointer p) = tySplice . parenSplice . mkVar $ p+++hsFuncXformer :: Function -> String+hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func)+                                       in if len > 0+                                          then "xform" <> show (len - 1)+                                          else "xformnull"+hsFuncXformer func@(Static _ _ _ _) =+  let len = length (genericFuncArgs func)+  in if len > 0+     then "xform" <> show (len - 1)+     else "xformnull"+hsFuncXformer func = let len = length (genericFuncArgs func)+                     in "xform" <> show len++++classConstraints :: Class -> Context ()+classConstraints = cxTuple . map ((\n->classA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents++extractArgRetTypes+  :: Maybe Class  -- ^ class (Nothing for top-level function)+  -> Bool         -- ^ is virtual function?+  -> CFunSig      -- ^ C type signature information for a given function      -- (Args,Types)           -- ^ (argument types, return type) of a given function+  -> HsFunSig     -- ^ Haskell type signature information for the function    --   ([Type ()],[Asst ()])  -- ^ (types, class constraints)+extractArgRetTypes mc isvirtual (CFunSig args ret) =+  let  (typs,s) = flip runState ([],(0 :: Int)) $ do+                    as <- mapM (mktyp . arg_type) args+                    r <- case ret of+                           SelfType -> case mc of+                                         Nothing -> error "extractArgRetTypes: SelfType return but no class"+                                         Just c -> if isvirtual then return (mkTVar "a") else return $ tycon ((fst.hsClassName) c)+                           x -> (return . convertCpp2HS Nothing) x+                    return (as ++ [tyapp (tycon "IO") r])+  in   HsFunSig { hsSigTypes = typs+                , hsSigConstraints = fst s+                }+ where addclass c = do+         (ctxts,n) <- get+         let cname = (fst.hsClassName) c+             iname = typeclassNameFromStr cname+             tvar = mkTVar ('c' : show n)+             ctxt1 = classA (unqual iname) [tvar]+             ctxt2 = classA (unqual "FPtr") [tvar]+         put (ctxt1:ctxt2:ctxts,n+1)+         return tvar+       addstring = do+         (ctxts,n) <- get+         let tvar = mkTVar ('c' : show n)+             ctxt = classA (unqual "Castable") [tvar,tycon "CString"]+         put (ctxt:ctxts,n+1)+         return tvar++       mktyp typ =+         case typ of+           SelfType -> return (mkTVar "a")+           CT CTString Const -> addstring+           CT _ _   -> return $ convertCpp2HS Nothing typ+           CPT (CPTClass c') _    -> addclass c'+           CPT (CPTClassRef c') _ -> addclass c'+           CPT (CPTClassCopy c') _ -> addclass c'+           CPT (CPTClassMove c') _ -> addclass c'+           -- it is not clear whether the following is okay or not.+           (TemplateApp x)    -> pure $+                                   convertCpp2HS Nothing (TemplateApp x)+           (TemplateAppRef x) -> pure $+                                   convertCpp2HS Nothing (TemplateAppRef x)+           (TemplateAppMove x)-> pure $+                                   convertCpp2HS Nothing (TemplateAppMove x)+           (TemplateType t)   -> pure $+                                   foldl1 tyapp (tycon (tclass_name t) : map mkTVar (tclass_params t))+           (TemplateParam p)      -> return (mkTVar p)+           Void -> return unit_tycon+           _ -> error ("No such c type : " <> show typ)++functionSignature :: Class -> Function -> Type ()+functionSignature c f =+  let HsFunSig typs assts = extractArgRetTypes+                              (Just c)+                              (isVirtualFunc f)+                              (CFunSig (genericFuncArgs f) (genericFuncRet f))+      ctxt = cxTuple assts+      arg0+        | isVirtualFunc f    = (mkTVar "a" :)+        | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :)+        | otherwise          = id+  in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs))++functionSignatureT :: TemplateClass -> TemplateFunction -> Type ()+functionSignatureT t TFun {..} =+  let (hname,_) = hsTemplateClassName t+      slf = foldl1 tyapp (tycon hname : map mkTVar (tclass_params t))+      ctyp = convertCpp2HS Nothing tfun_ret+      lst = slf : map (convertCpp2HS Nothing . arg_type) tfun_args+  in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])+functionSignatureT t TFunNew {..} =+  let ctyp = convertCpp2HS Nothing (TemplateType t)+      lst = map (convertCpp2HS Nothing . arg_type) tfun_new_args+  in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])+functionSignatureT t TFunDelete =+  let ctyp = convertCpp2HS Nothing (TemplateType t)+  in ctyp `tyfun` (tyapp (tycon "IO") unit_tycon)+functionSignatureT t TFunOp {..} =+  let (hname,_) = hsTemplateClassName t+      slf = foldl1 tyapp (tycon hname : map mkTVar (tclass_params t))+      ctyp = convertCpp2HS Nothing tfun_ret+      lst = slf : map (convertCpp2HS Nothing . arg_type) (argsFromOpExp tfun_opexp)+  in foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])++-- TODO: rename this and combine this with functionSignatureTMF+functionSignatureTT :: TemplateClass -> TemplateFunction -> Type ()+functionSignatureTT t f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])+ where+  (hname,_) = hsTemplateClassName t+  ctyp = case f of+           TFun {..}    -> convertCpp2HS4Tmpl e Nothing spls tfun_ret+           TFunNew {..} -> convertCpp2HS4Tmpl e Nothing spls (TemplateType t)+           TFunDelete   -> unit_tycon+           TFunOp {..}  -> convertCpp2HS4Tmpl e Nothing spls tfun_ret+  e = foldl1 tyapp (tycon hname : spls)+  spls = map (tySplice . parenSplice . mkVar) $ tclass_params t+  lst =+    case f of+      TFun {..}    -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) tfun_args+      TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spls . arg_type) tfun_new_args+      TFunDelete   -> [e]+      TFunOp {..}  -> e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (argsFromOpExp tfun_opexp)++-- TODO: rename this and combine this with functionSignatureTT+functionSignatureTMF :: Class -> TemplateMemberFunction -> Type ()+functionSignatureTMF c f = foldr1 tyfun (lst <> [tyapp (tycon "IO") ctyp])+  where+    spls = map (tySplice . parenSplice . mkVar) (tmf_params f)+    ctyp = convertCpp2HS4Tmpl e Nothing spls (tmf_ret f)+    e = tycon (fst (hsClassName c))+    lst = e : map (convertCpp2HS4Tmpl e Nothing spls . arg_type) (tmf_args f)+++tmplAccessorToTFun :: Variable -> Accessor -> TemplateFunction+tmplAccessorToTFun v@(Variable (Arg {..})) a =+  case a of+    Getter -> TFun { tfun_ret   = arg_type+                   , tfun_name  = tmplAccessorName v Getter+                   , tfun_oname = tmplAccessorName v Getter+                   , tfun_args  = []+                   }+    Setter -> TFun { tfun_ret   = Void+                   , tfun_name  = tmplAccessorName v Setter+                   , tfun_oname = tmplAccessorName v Setter+                   , tfun_args = [Arg arg_type "value"]+                   }+++accessorCFunSig :: Types -> Accessor -> CFunSig+accessorCFunSig typ Getter = CFunSig [] typ+accessorCFunSig typ Setter = CFunSig [Arg typ "x"] Void+++accessorSignature :: Class -> Variable -> Accessor -> Type ()+accessorSignature c v accessor =+  let csig = accessorCFunSig (arg_type (unVariable v)) accessor+      HsFunSig typs assts = extractArgRetTypes (Just c) False csig+      ctxt = cxTuple assts+      arg0 = (mkTVar (fst (hsClassName c)) :)+  in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs))+++-- | this is for FFI type.+hsFFIFuncTyp :: Maybe (Selfness, Class) -> CFunSig -> Type ()+hsFFIFuncTyp msc (CFunSig args ret) =+  foldr1 tyfun $ case msc of+                   Nothing         -> argtyps <> [tyapp (tycon "IO") rettyp]+                   Just (Self,_)   -> selftyp: argtyps <> [tyapp (tycon "IO") rettyp]+                   Just (NoSelf,_) -> argtyps <> [tyapp (tycon "IO") rettyp]+  where argtyps :: [Type ()]+        argtyps = map (hsargtype . arg_type) args+        rettyp :: Type ()+        rettyp  = hsrettype ret+        selftyp = case msc of+                    Just (_,c) -> tyapp tyPtr (tycon (snd (hsClassName c)))+                    Nothing    -> error "hsFFIFuncTyp: no self for top level function"+        hsargtype :: Types -> Type ()+        hsargtype (CT ctype _)               = convertC2HS ctype+        hsargtype (CPT (CPTClass d) _)       = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsargtype (CPT (CPTClassRef d) _)    = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsargtype (CPT (CPTClassMove d) _)    = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsargtype (CPT (CPTClassCopy d) _)    = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsargtype (TemplateApp x)    = tyapp tyPtr $+                                         foldl1 tyapp $+                                           map tycon $+                                            rawname : map hsClassNameForTArg (tapp_tparams x)+          where rawname = snd (hsTemplateClassName (tapp_tclass x))+        hsargtype (TemplateAppRef x) = tyapp tyPtr $+                                         foldl1 tyapp $+                                           map tycon $+                                             rawname : map hsClassNameForTArg (tapp_tparams x)+          where rawname = snd (hsTemplateClassName (tapp_tclass x))+        hsargtype (TemplateAppMove x)= tyapp tyPtr $+                                         foldl1 tyapp $+                                           map tycon $+                                             rawname : map hsClassNameForTArg (tapp_tparams x)+          where rawname = snd (hsTemplateClassName (tapp_tclass x))+        hsargtype (TemplateType t)           = tyapp tyPtr $ foldl1 tyapp (tycon rawname : map mkTVar (tclass_params t))+          where rawname = snd (hsTemplateClassName t)+        hsargtype (TemplateParam p)          = mkTVar p+        hsargtype SelfType                   = selftyp+        hsargtype _ = error "hsFuncTyp: undefined hsargtype"+        ---------------------------------------------------------+        hsrettype Void                       = unit_tycon+        hsrettype SelfType                   = selftyp+        hsrettype (CT ctype _)               = convertC2HS ctype+        hsrettype (CPT (CPTClass d) _)       = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (CPT (CPTClassRef d) _)    = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (CPT (CPTClassCopy d) _)   = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (CPT (CPTClassMove d) _)   = tyapp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (TemplateApp x)    = tyapp tyPtr $+                                         foldl1 tyapp $+                                           map tycon $+                                            rawname : map hsClassNameForTArg (tapp_tparams x)+          where rawname = snd (hsTemplateClassName (tapp_tclass x))+        hsrettype (TemplateAppRef x) = tyapp tyPtr $+                                         foldl1 tyapp $+                                           map tycon $+                                            rawname : map hsClassNameForTArg (tapp_tparams x)+          where rawname = snd (hsTemplateClassName (tapp_tclass x))+        hsrettype (TemplateAppMove x)= tyapp tyPtr $+                                         foldl1 tyapp $+                                           map tycon $+                                            rawname : map hsClassNameForTArg (tapp_tparams x)+          where rawname = snd (hsTemplateClassName (tapp_tclass x))+        hsrettype (TemplateType t)   = tyapp tyPtr $+                                         foldl1 tyapp (tycon rawname : map mkTVar (tclass_params t))+          where rawname = snd (hsTemplateClassName t)+        hsrettype (TemplateParam p)          = mkTVar p+        hsrettype (TemplateParamPointer p)   = mkTVar p++++genericFuncRet :: Function -> Types+genericFuncRet f =+  case f of+    Constructor _ _ -> self_+    Virtual t _ _ _ -> t+    NonVirtual t _ _ _-> t+    Static t _ _ _ -> t+    Destructor _ -> void_++genericFuncArgs :: Function -> [Arg]+genericFuncArgs (Destructor _) = []+genericFuncArgs f = func_args f