fficxx 0.6 → 0.7.0.0

raw patch · 27 files changed

+4949/−3663 lines, 27 filesdep +arraydep +dotgendep −eitherdep ~haskell-src-extsPVP ok

version bump matches the API change (PVP)

Dependencies added: array, dotgen

Dependencies removed: either

Dependency ranges changed: haskell-src-exts

API changes (from Hackage documentation)

Files

• ChangeLog.md +62/−0
• LICENSE +1/−1
• fficxx.cabal +12/−6
• src/FFICXX/Generate/Builder.hs +151/−118
• src/FFICXX/Generate/Code/Cabal.hs +189/−176
• src/FFICXX/Generate/Code/Cpp.hs +475/−400
• src/FFICXX/Generate/Code/HsCast.hs +29/−19
• src/FFICXX/Generate/Code/HsFFI.hs +71/−74
• src/FFICXX/Generate/Code/HsFrontEnd.hs +283/−201
• src/FFICXX/Generate/Code/HsProxy.hs +38/−28
• src/FFICXX/Generate/Code/HsTemplate.hs +588/−321
• src/FFICXX/Generate/Code/Primitive.hs +1064/−1000
• src/FFICXX/Generate/Config.hs +21/−21
• src/FFICXX/Generate/ContentMaker.hs +744/−526
• src/FFICXX/Generate/Dependency.hs +342/−285
• src/FFICXX/Generate/Dependency/Graph.hs +117/−0
• src/FFICXX/Generate/Name.hs +113/−72
• src/FFICXX/Generate/QQ/Verbatim.hs +18/−8
• src/FFICXX/Generate/Type/Annotate.hs +3/−6
• src/FFICXX/Generate/Type/Cabal.hs +58/−55
• src/FFICXX/Generate/Type/Class.hs +191/−168
• src/FFICXX/Generate/Type/Config.hs +22/−22
• src/FFICXX/Generate/Type/Module.hs +97/−64
• src/FFICXX/Generate/Type/PackageInterface.hs +5/−5
• src/FFICXX/Generate/Util.hs +46/−41
• src/FFICXX/Generate/Util/DepGraph.hs +36/−0
• src/FFICXX/Generate/Util/HaskellSrcExts.hs +173/−46

@@ -0,0 +1,62 @@+# Changelog for fficxx++## 0.7.0.0++- Show generated module dependency graph (#203)+- Fix incorrect hs-boot (#199)+- Simplify Nix script and support for multiple GHC versions in build (#196)+- aarch64-darwin support (#195)+- Implicit imports cleanup (#193)+- Upgrade to NixOS 21.11. (#192)+- CI action for ormolu formatting (#190)+- github action CI with nix build targets (#189)+- format all Haskell files by ormolu 0.0.3 (#180)+++## 0.6++- no more impure <nixpkgs> (#178)+- Duplicated template instances are safe (#176)+- Update for haskell-src-exts >= 1.22 (#174)+- change to_const/to_nonconst to from_X_to_Y (#172)+- std::map<k,v>::iterator is now supported. (#168)+- accessor for member variables of C++ template (#167)+- Support nested types inside template class (#163)+- Automatic dependency import in template class module (#162)+- cabal package generation and testing using hspec (#159)+- fficxx-test: stdcxx tests are rewritten as hspec tests (#158)+- multi-parameter template for function arguments and template member functions (#156)+- C++ multi-parameter template interfaced via fficxx! (#154)+- one class or template class per one haskell module! (#151)+- Inline C++ code generation for template member function (#149)+- Inline C++ code generation for std::function (#148)+- CDefinition. Unified newline treatment in Macro definition (#143)+- More ASTification with CMacroApp (#141)+- Declaration generation uses intermediate pseudo-AST representation (#140)+- Further towards intermediate reps for C++ code generation (#139)+- Further removing #include and using namespace (#138)+- Start C intermediate rep (#137)+- Convert (Types,String) to Arg (#134)+- no more stub.cc (#132)++## 0.5.1++## 0.5.0.1++## 0.5++## 0.4.1++## 0.4++## 0.3.1++## 0.3++## 0.2.1++## 0.2++## 0.1.0++## 0.1

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

@@ -1,14 +1,17 @@+Cabal-Version:  3.0 Name:           fficxx-Version:        0.6+Version:        0.7.0.0 Synopsis:       Automatic C++ binding generation Description:    fficxx is an automatic haskell Foreign Function Interface (FFI) generator to C++.-License:        BSD3+License:        BSD-2-Clause License-file:   LICENSE Author:         Ian-Woo Kim Maintainer:     Ian-Woo Kim <ianwookim@gmail.com> Build-Type:     Simple+Tested-With:    GHC == 9.0.2 || == 9.2.4 || == 9.4.2 Category:       FFI Tools-Cabal-Version:  >= 1.10+Extra-Source-Files:+  ChangeLog.md  Source-repository head   type: git@@ -16,21 +19,22 @@  Library   hs-source-dirs: src-  default-language: Haskell2010  +  default-language: Haskell2010   Build-Depends: base == 4.*                , aeson                , aeson-pretty+               , array                , bytestring                , Cabal                , containers                , data-default                , directory-               , either+               , dotgen                , errors                , fficxx-runtime                , filepath>1                , hashable-               , haskell-src-exts >= 1.18+               , haskell-src-exts >= 1.22                , lens > 3                , mtl>2                , process@@ -54,9 +58,11 @@                FFICXX.Generate.Code.Primitive                FFICXX.Generate.ContentMaker                FFICXX.Generate.Dependency+               FFICXX.Generate.Dependency.Graph                FFICXX.Generate.Name                FFICXX.Generate.QQ.Verbatim                FFICXX.Generate.Util+               FFICXX.Generate.Util.DepGraph                FFICXX.Generate.Util.HaskellSrcExts                FFICXX.Generate.Type.Annotate                FFICXX.Generate.Type.Cabal

@@ -3,52 +3,56 @@  module FFICXX.Generate.Builder where -import           Control.Monad                           ( void, when )-import qualified Data.ByteString.Lazy.Char8        as L-import           Data.Char                               ( toUpper )-import           Data.Digest.Pure.MD5                    ( md5 )-import           Data.Foldable                           ( for_ )-import           Data.Monoid                             ( (<>), mempty )-import           Language.Haskell.Exts.Pretty            ( prettyPrint )-import           System.FilePath                         ( (</>), (<.>), splitExtension )-import           System.Directory                        ( copyFile-                                                         , createDirectoryIfMissing-                                                         , doesFileExist-                                                         )-import           System.IO                               ( hPutStrLn, withFile, IOMode(..) )-import           System.Process                          ( readProcess )----import           FFICXX.Runtime.CodeGen.Cxx              ( HeaderName(..) )----import           FFICXX.Generate.Code.Cabal              ( buildCabalFile-                                                         , buildJSONFile-                                                         )-import           FFICXX.Generate.Dependency              ( findModuleUnitImports-                                                         , mkHSBOOTCandidateList-                                                         , mkPackageConfig-                                                         )-import           FFICXX.Generate.Config                  ( FFICXXConfig(..)-                                                         , SimpleBuilderConfig(..)-                                                         )-import           FFICXX.Generate.ContentMaker-import           FFICXX.Generate.Type.Cabal              ( Cabal(..)-                                                         , CabalName(..)-                                                         , AddCInc(..)-                                                         , AddCSrc(..)-                                                         )-import           FFICXX.Generate.Type.Class              ( hasProxy )-import           FFICXX.Generate.Type.Module             ( ClassImportHeader(..)-                                                         , ClassModule(..)-                                                         , PackageConfig(..)-                                                         , TemplateClassModule(..)-                                                         , TopLevelImportHeader(..)-                                                         )-import           FFICXX.Generate.Util                    ( moduleDirFile )---+import Control.Monad (void, when)+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char (toUpper)+import Data.Digest.Pure.MD5 (md5)+import Data.Foldable (for_)+import qualified Data.Text as T+import FFICXX.Generate.Code.Cabal (buildCabalFile, buildJSONFile)+import FFICXX.Generate.Config+  ( FFICXXConfig (..),+    SimpleBuilderConfig (..),+  )+import qualified FFICXX.Generate.ContentMaker as C+import FFICXX.Generate.Dependency+  ( findModuleUnitImports,+    mkPackageConfig,+  )+import FFICXX.Generate.Dependency.Graph+  ( constructDepGraph,+    findDepCycles,+    gatherHsBootSubmodules,+  )+import FFICXX.Generate.Type.Cabal+  ( AddCInc (..),+    AddCSrc (..),+    Cabal (..),+    CabalName (..),+  )+import FFICXX.Generate.Type.Class (hasProxy)+import FFICXX.Generate.Type.Module+  ( ClassImportHeader (..),+    ClassModule (..),+    PackageConfig (..),+    TemplateClassImportHeader (..),+    TemplateClassModule (..),+    TopLevelImportHeader (..),+  )+import FFICXX.Generate.Util (moduleDirFile)+import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))+import Language.Haskell.Exts.Pretty (prettyPrint)+import System.Directory+  ( copyFile,+    createDirectoryIfMissing,+    doesFileExist,+  )+import System.FilePath (splitExtension, (<.>), (</>))+import System.IO (IOMode (..), hPutStrLn, withFile)+import System.Process (readProcess)  macrofy :: String -> String-macrofy = map ((\x->if x=='-' then '_' else x) . toUpper)-+macrofy = map ((\x -> if x == '-' then '_' else x) . toUpper)  simpleBuilder :: FFICXXConfig -> SimpleBuilderConfig -> IO () simpleBuilder cfg sbc = do@@ -63,24 +67,35 @@         toplevelfunctions         templates         extralibs+        cxxopts         extramods-        staticFiles-        = sbc+        staticFiles =+          sbc       pkgname = cabal_pkgname cabal   putStrLn ("Generating " <> unCabalName pkgname)   let workingDir = fficxxconfig_workingDir cfg       installDir = fficxxconfig_installBaseDir cfg-      staticDir  = fficxxconfig_staticFileDir cfg-+      staticDir = fficxxconfig_staticFileDir cfg       pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) =         mkPackageConfig           (pkgname, findModuleUnitImports mumap)-          (classes, toplevelfunctions,templates,extramods)+          (classes, toplevelfunctions, templates, extramods)           (cabal_additional_c_incs cabal)           (cabal_additional_c_srcs cabal)-      hsbootlst = mkHSBOOTCandidateList mods       cabalFileName = unCabalName pkgname <.> "cabal"       jsonFileName = unCabalName pkgname <.> "json"+      allClasses = fmap (Left . tcihTClass) templates ++ fmap Right classes+      depCycles =+        findDepCycles $+          constructDepGraph allClasses toplevelfunctions+      -- for now, put this function here+      -- This function is a little ad hoc, only for Interface.hs.+      -- But as of now, we support hs-boot for ordinary class only.+      mkHsBootCandidateList :: [ClassModule] -> [ClassModule]+      mkHsBootCandidateList ms =+        let hsbootSubmods = gatherHsBootSubmodules depCycles+         in filter (\c -> cmModule c <.> "Interface" `elem` hsbootSubmods) ms+      hsbootlst = mkHsBootCandidateList mods   --   createDirectoryIfMissing True workingDir   createDirectoryIfMissing True installDir@@ -88,114 +103,137 @@   createDirectoryIfMissing True (installDir </> "csrc")   --   putStrLn "Copying static files"-  mapM_ (\x->copyFileWithMD5Check (staticDir </> x) (installDir </> x)) staticFiles+  mapM_ (\x -> copyFileWithMD5Check (staticDir </> x) (installDir </> x)) staticFiles   --   putStrLn "Generating Cabal file"-  buildCabalFile cabal topLevelMod pkgconfig extralibs (workingDir</>cabalFileName)+  buildCabalFile cabal topLevelMod pkgconfig extralibs cxxopts (workingDir </> cabalFileName)   --   putStrLn "Generating JSON file"-  buildJSONFile cabal topLevelMod pkgconfig extralibs (workingDir</>jsonFileName)+  buildJSONFile cabal topLevelMod pkgconfig extralibs cxxopts (workingDir </> jsonFileName)   --   putStrLn "Generating Header file"-  let-      gen :: FilePath -> String -> IO ()+  let gen :: FilePath -> String -> IO ()       gen file str =         let path = workingDir </> file in withFile path WriteMode (flip hPutStrLn str)---  gen (unCabalName pkgname <> "Type.h") (buildTypeDeclHeader (map cihClass cihs))-  for_ cihs $ \hdr -> gen-                        (unHdrName (cihSelfHeader hdr))-                        (buildDeclHeader (unCabalName pkgname) hdr)+  gen (unCabalName pkgname <> "Type.h") (C.buildTypeDeclHeader (map cihClass cihs))+  for_ cihs $ \hdr ->+    gen+      (unHdrName (cihSelfHeader hdr))+      (C.buildDeclHeader (unCabalName pkgname) hdr)   gen     (tihHeaderFileName tih <.> "h")-    (buildTopLevelHeader (unCabalName pkgname) tih)-+    (C.buildTopLevelHeader (unCabalName pkgname) tih)   putStrLn "Generating Cpp file"-  for_ cihs (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr))-  gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelCppDef tih)+  for_ cihs (\hdr -> gen (cihSelfCpp hdr) (C.buildDefMain hdr))+  gen (tihHeaderFileName tih <.> "cpp") (C.buildTopLevelCppDef tih)   --   putStrLn "Generating Additional Header/Source"   for_ (cabal_additional_c_incs cabal) (\(AddCInc hdr txt) -> gen hdr txt)   for_ (cabal_additional_c_srcs cabal) (\(AddCSrc hdr txt) -> gen hdr txt)   --   putStrLn "Generating RawType.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "RawType" <.> "hs")-                      (prettyPrint (buildRawTypeHs m))+  for_ mods $ \m ->+    gen+      (cmModule m <.> "RawType" <.> "hs")+      (prettyPrint (C.buildRawTypeHs m))   --   putStrLn "Generating FFI.hsc"-  for_ mods $ \m -> gen-                      (cmModule m <.> "FFI" <.> "hsc")-                      (prettyPrint (buildFFIHsc m))+  for_ mods $ \m ->+    gen+      (cmModule m <.> "FFI" <.> "hsc")+      (prettyPrint (C.buildFFIHsc m))   --   putStrLn "Generating Interface.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "Interface" <.> "hs")-                      (prettyPrint (buildInterfaceHs mempty m))+  for_ mods $ \m ->+    gen+      (cmModule m <.> "Interface" <.> "hs")+      (prettyPrint (C.buildInterfaceHs mempty depCycles m))   --   putStrLn "Generating Cast.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "Cast" <.> "hs")-                      (prettyPrint (buildCastHs m))+  for_ mods $ \m ->+    gen+      (cmModule m <.> "Cast" <.> "hs")+      (prettyPrint (C.buildCastHs m))   --   putStrLn "Generating Implementation.hs"-  for_ mods $ \m -> gen-                      (cmModule m <.> "Implementation" <.> "hs")-                      (prettyPrint (buildImplementationHs mempty m))- --+  for_ mods $ \m ->+    gen+      (cmModule m <.> "Implementation" <.> "hs")+      (prettyPrint (C.buildImplementationHs mempty m))+  --   putStrLn "Generating Proxy.hs"   for_ mods $ \m ->     when (hasProxy . cihClass . cmCIH $ m) $-      gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (buildProxyHs m))+      gen (cmModule m <.> "Proxy" <.> "hs") (prettyPrint (C.buildProxyHs m))   --   putStrLn "Generating Template.hs"-  for_ tcms $ \m -> gen-                      (tcmModule m <.> "Template" <.> "hs")-                      (prettyPrint (buildTemplateHs m))+  for_ tcms $ \m ->+    gen+      (tcmModule m <.> "Template" <.> "hs")+      (prettyPrint (C.buildTemplateHs m))   --   putStrLn "Generating TH.hs"-  for_ tcms $ \m -> gen-                      (tcmModule m <.> "TH" <.> "hs")-                      (prettyPrint (buildTHHs m))-+  for_ tcms $ \m ->+    gen+      (tcmModule m <.> "TH" <.> "hs")+      (prettyPrint (C.buildTHHs m))   --   -- TODO: Template.hs-boot need to be generated as well   putStrLn "Generating hs-boot file"-  for_ hsbootlst $ \m -> gen-                           (m <.> "Interface" <.> "hs-boot")-                           (prettyPrint (buildInterfaceHSBOOT m))+  -- This is a hack since haskell-src-exts always codegen () => instead of empty+  -- string for an empty context, which have different meanings in hs-boot file.+  -- Therefore, we get rid of them.+  let hsBootHackClearEmptyContexts = T.unpack . T.replace "() =>" "" . T.pack+  for_ hsbootlst $ \m -> do+    gen+      (cmModule m <.> "Interface" <.> "hs-boot")+      (hsBootHackClearEmptyContexts $ prettyPrint (C.buildInterfaceHsBoot depCycles m))   --   putStrLn "Generating Module summary file"-  for_ mods $ \m -> gen-                      (cmModule m <.> "hs")-                      (prettyPrint (buildModuleHs m))+  for_ mods $ \m ->+    gen+      (cmModule m <.> "hs")+      (prettyPrint (C.buildModuleHs m))   --+  putStrLn "Generating Top-level Ordinary Module"+  gen (topLevelMod <.> "Ordinary" <.> "hs") (prettyPrint (C.buildTopLevelOrdinaryHs (topLevelMod <> ".Ordinary") (mods, tcms) tih))+  --+  putStrLn "Generating Top-level Template Module"+  gen+    (topLevelMod <.> "Template" <.> "hs")+    (prettyPrint (C.buildTopLevelTemplateHs (topLevelMod <> ".Template") tih))+  --+  putStrLn "Generating Top-level TH Module"+  gen+    (topLevelMod <.> "TH" <.> "hs")+    (prettyPrint (C.buildTopLevelTHHs (topLevelMod <> ".TH") tih))+  --   putStrLn "Generating Top-level Module"-  gen (topLevelMod <.> "hs") (prettyPrint (buildTopLevelHs topLevelMod (mods,tcms) tih))+  gen+    (topLevelMod <.> "hs")+    (prettyPrint (C.buildTopLevelHs topLevelMod (mods, tcms)))   --   putStrLn "Copying generated files to target directory"   touch (workingDir </> "LICENSE")-  copyFileWithMD5Check (workingDir </> cabalFileName)  (installDir </> cabalFileName)-  copyFileWithMD5Check (workingDir </> jsonFileName)  (installDir </> jsonFileName)+  copyFileWithMD5Check (workingDir </> cabalFileName) (installDir </> cabalFileName)+  copyFileWithMD5Check (workingDir </> jsonFileName) (installDir </> jsonFileName)   copyFileWithMD5Check (workingDir </> "LICENSE") (installDir </> "LICENSE")--  copyCppFiles workingDir (csrcDir installDir) (unCabalName pkgname) pkgconfig-  for_ mods (copyModule workingDir (srcDir installDir))-  for_ tcms (copyTemplateModule workingDir (srcDir installDir))-  moduleFileCopy workingDir (srcDir installDir) $ topLevelMod <.> "hs"-+  copyCppFiles workingDir (C.csrcDir installDir) (unCabalName pkgname) pkgconfig+  for_ mods (copyModule workingDir (C.srcDir installDir))+  for_ tcms (copyTemplateModule workingDir (C.srcDir installDir))+  putStrLn "Copying Ordinary"+  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Ordinary" <.> "hs"+  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "Template" <.> "hs"+  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "TH" <.> "hs"+  moduleFileCopy workingDir (C.srcDir installDir) $ topLevelMod <.> "hs"   putStrLn "----------------------------------------------------"   putStrLn "-- Code generation has been completed. Enjoy!     --"   putStrLn "----------------------------------------------------" - -- | some dirty hack. later, we will do it with more proper approcah.- touch :: FilePath -> IO () touch fp = void (readProcess "touch" [fp] "") - copyFileWithMD5Check :: FilePath -> FilePath -> IO () copyFileWithMD5Check src tgt = do   b <- doesFileExist tgt@@ -206,7 +244,6 @@       if srcmd5 == tgtmd5 then return () else copyFile src tgt     else copyFile src tgt - copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO () copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ _tcihs acincs acsrcs) = do   let thfile = cprefix <> "Type.h"@@ -217,32 +254,28 @@     >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))   doesFileExist (wdir </> tlcppfile)     >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))-  for_ cihs $ \header-> do+  for_ cihs $ \header -> do     let hfile = unHdrName (cihSelfHeader header)         cppfile = cihSelfCpp header     copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile)     copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)-   for_ acincs $ \(AddCInc header _) ->     copyFileWithMD5Check (wdir </> header) (ddir </> header)-   for_ acsrcs $ \(AddCSrc csrc _) ->     copyFileWithMD5Check (wdir </> csrc) (ddir </> csrc) - moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO () moduleFileCopy wdir ddir fname = do-  let (fnamebody,fnameext) = splitExtension fname-      (mdir,mfile) = moduleDirFile fnamebody+  let (fnamebody, fnameext) = splitExtension fname+      (mdir, mfile) = moduleDirFile fnamebody       origfpath = wdir </> fname-      (mfile',_mext') = splitExtension mfile+      (mfile', _mext') = splitExtension mfile       newfpath = ddir </> mdir </> mfile' <> fnameext   b <- doesFileExist origfpath   when b $ do     createDirectoryIfMissing True (ddir </> mdir)     copyFileWithMD5Check origfpath newfpath - copyModule :: FilePath -> FilePath -> ClassModule -> IO () copyModule wdir ddir m = do   let modbase = cmModule m@@ -254,8 +287,8 @@   moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs"   moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot"   when (hasProxy . cihClass . cmCIH $ m) $-    moduleFileCopy wdir ddir $ modbase <> ".Proxy.hs"-+    moduleFileCopy wdir ddir $+      modbase <> ".Proxy.hs"  copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO () copyTemplateModule wdir ddir m = do

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

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

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

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

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

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

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

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

@@ -1,26 +1,26 @@ module FFICXX.Generate.Config where -import FFICXX.Generate.Type.Cabal  ( Cabal )-import FFICXX.Generate.Type.Class  ( Class, TopLevel )-import FFICXX.Generate.Type.Config ( ModuleUnitMap(..) )-import FFICXX.Generate.Type.Module ( TemplateClassImportHeader )-+import FFICXX.Generate.Type.Cabal (Cabal)+import FFICXX.Generate.Type.Class (Class, TopLevel)+import FFICXX.Generate.Type.Config (ModuleUnitMap (..))+import FFICXX.Generate.Type.Module (TemplateClassImportHeader) -data FFICXXConfig = FFICXXConfig {-    fficxxconfig_workingDir     :: FilePath-  , fficxxconfig_installBaseDir :: FilePath-  , fficxxconfig_staticFileDir  :: FilePath-  } deriving Show+data FFICXXConfig = FFICXXConfig+  { fficxxconfig_workingDir :: FilePath,+    fficxxconfig_installBaseDir :: FilePath,+    fficxxconfig_staticFileDir :: FilePath+  }+  deriving (Show) -data SimpleBuilderConfig =-  SimpleBuilderConfig {-    sbcTopModule     :: String-  , sbcModUnitMap    :: ModuleUnitMap-  , sbcCabal         :: Cabal-  , sbcClasses       :: [Class]-  , sbcTopLevels     :: [TopLevel]-  , sbcTemplates     :: [TemplateClassImportHeader]-  , sbcExtraLibs     :: [String]-  , sbcExtraDeps     :: [(String,[String])]-  , sbcStaticFiles   :: [String]+data SimpleBuilderConfig = SimpleBuilderConfig+  { sbcTopModule :: String,+    sbcModUnitMap :: ModuleUnitMap,+    sbcCabal :: Cabal,+    sbcClasses :: [Class],+    sbcTopLevels :: [TopLevel],+    sbcTemplates :: [TemplateClassImportHeader],+    sbcExtraLibs :: [String],+    sbcCxxOpts :: [String],+    sbcExtraDeps :: [(String, [String])],+    sbcStaticFiles :: [String]   }

@@ -3,529 +3,747 @@  module FFICXX.Generate.ContentMaker where -import Control.Lens                           ( (&), (.~), at )-import Control.Monad.Trans.Reader-import Data.Either                            ( rights )-import Data.Functor.Identity                  ( Identity )-import qualified Data.Map as M-import Data.Maybe                             ( mapMaybe  )-import Data.Monoid                            ( (<>) )-import Data.List                              ( intercalate, nub )-import Data.List.Split                        ( splitOn )-import Language.Haskell.Exts.Syntax           ( Module(..)-                                              , Decl(..)-                                              )-import System.FilePath                        ( (<.>), (</>) )----import FFICXX.Runtime.CodeGen.Cxx             ( HeaderName(..) )-import qualified FFICXX.Runtime.CodeGen.Cxx as R----import FFICXX.Generate.Code.Cpp               ( genAllCppHeaderInclude-                                              , genCppDefMacroAccessor-                                              , genCppDefMacroNonVirtual-                                              , genCppDefMacroTemplateMemberFunction-                                              , genCppDefMacroVirtual-                                              , genCppDefInstAccessor-                                              , genCppDefInstNonVirtual-                                              , genCppDefInstVirtual-                                              , genCppHeaderInstAccessor-                                              , genCppHeaderInstNonVirtual-                                              , genCppHeaderInstVirtual-                                              , genCppHeaderMacroAccessor-                                              , genCppHeaderMacroType-                                              , genCppHeaderMacroVirtual-                                              , genCppHeaderMacroNonVirtual-                                              , genTopLevelCppDefinition-                                              , topLevelDecl-                                              )-import FFICXX.Generate.Code.HsCast            ( genHsFrontInstCastable-                                              , genHsFrontInstCastableSelf-                                              )-import FFICXX.Generate.Code.HsFFI             ( genHsFFI-                                              , genImportInFFI-                                              , genTopLevelFFI-                                              )-import FFICXX.Generate.Code.HsFrontEnd        ( genExport-                                              , genExtraImport-                                              , genHsFrontDecl-                                              , genHsFrontDowncastClass-                                              , genHsFrontInst-                                              , genHsFrontInstNew-                                              , genHsFrontInstNonVirtual-                                              , genHsFrontInstStatic-                                              , genHsFrontInstVariables-                                              , genHsFrontUpcastClass-                                              , genImportInCast-                                              , genImportInImplementation-                                              , genImportInInterface-                                              , genImportInModule-                                              , genImportInTopLevel-                                              , genTopLevelDef-                                              , hsClassRawType-                                              )-import FFICXX.Generate.Code.HsProxy           ( genProxyInstance )-import FFICXX.Generate.Code.HsTemplate        ( genImportInTemplate-                                              , genImportInTH-                                              , genTemplateMemberFunctions-                                              , genTmplInstance-                                              , genTmplInterface-                                              , genTmplImplementation-                                              )-import FFICXX.Generate.Dependency-import FFICXX.Generate.Name                   ( ffiClassName, hsClassName-                                              , hsFrontNameForTopLevel-                                              )-import FFICXX.Generate.Type.Annotate          ( AnnotateMap )-import FFICXX.Generate.Type.Class             ( Class(..)-                                              , ClassGlobal(..)-                                              , DaughterMap-                                              , ProtectedMethod(..)-                                              , isAbstractClass-                                              )-import FFICXX.Generate.Type.Module            ( ClassImportHeader(..)-                                              , ClassModule(..)-                                              , TemplateClassImportHeader(..)-                                              , TemplateClassModule(..)-                                              , TopLevelImportHeader(..)-                                              )-import FFICXX.Generate.Type.PackageInterface  ( ClassName(..)-                                              , PackageInterface-                                              , PackageName(..)-                                              )-import FFICXX.Generate.Util.HaskellSrcExts---srcDir :: FilePath -> FilePath-srcDir installbasedir = installbasedir </> "src"--csrcDir :: FilePath -> FilePath-csrcDir installbasedir = installbasedir </> "csrc"------ common function for daughter---- |-mkGlobal :: [Class] -> ClassGlobal-mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap----- |-buildDaughterDef ::-     ((String,[Class]) -> String)-  -> DaughterMap-  -> String-buildDaughterDef f m =-    let lst = M.toList m-        f' (x,xs) =  f (x,filter (not.isAbstractClass) xs)-    in (concatMap f' lst)---- |-buildParentDef :: ((Class,Class) -> [R.CStatement Identity]) -> Class -> [R.CStatement Identity]-buildParentDef f cls = concatMap (\p -> f (p,cls)) . class_allparents $ cls---- |-mkProtectedFunctionList :: Class -> [R.CMacro Identity]-mkProtectedFunctionList c =-    map (\x-> R.Define (R.sname ("IS_" <> class_name c <> "_" <> x <> "_PROTECTED")) [] [R.CVerbatim "()"])-  . unProtected-  . class_protected-  $ c---- |-buildTypeDeclHeader ::-     [Class]-  -> String-buildTypeDeclHeader classes =-  let typeDeclBodyStmts =-        intercalate [R.EmptyLine] $-          map (map R.CRegular . genCppHeaderMacroType) classes-  in R.renderBlock $-       R.ExternC $-         [ R.Pragma R.Once, R.EmptyLine ] <> typeDeclBodyStmts----- |-buildDeclHeader ::-     String     -- ^ C prefix-  -> ClassImportHeader-  -> String-buildDeclHeader cprefix header =-  let classes = [cihClass header]-      aclass = cihClass header-      declHeaderStmts =-           [ R.Include (HdrName (cprefix ++ "Type.h")) ]-        <> map R.Include (cihIncludedHPkgHeadersInH header)-      vdecl  = map genCppHeaderMacroVirtual    classes-      nvdecl = map genCppHeaderMacroNonVirtual classes-      acdecl = map genCppHeaderMacroAccessor   classes-      vdef   = map genCppDefMacroVirtual       classes-      nvdef  = map genCppDefMacroNonVirtual    classes-      acdef  = map genCppDefMacroAccessor      classes-      tmpldef= map (\c -> map (genCppDefMacroTemplateMemberFunction c) (class_tmpl_funcs c)) classes-      declDefStmts =-        intercalate [R.EmptyLine] $ [vdecl,nvdecl,acdecl,vdef,nvdef,acdef]++tmpldef-      classDeclStmts =-        -- NOTE: Deletable is treated specially.-        -- TODO: We had better make it as a separate constructor in Class.-        if (fst.hsClassName) aclass /= "Deletable"-        then    buildParentDef (\(p,c) -> [genCppHeaderInstVirtual (p,c), R.CEmptyLine]) aclass-             <> [genCppHeaderInstVirtual (aclass, aclass), R.CEmptyLine]-             <> concatMap (\c -> [genCppHeaderInstNonVirtual c, R.CEmptyLine]) classes-             <> concatMap (\c -> [genCppHeaderInstAccessor c, R.CEmptyLine]) classes-        else []-  in R.renderBlock $-       R.ExternC $-            [ R.Pragma R.Once, R.EmptyLine ]-         <> declHeaderStmts-         <> [ R.EmptyLine ]-         <> declDefStmts-         <> [ R.EmptyLine ]-         <> map R.CRegular classDeclStmts---- |-buildDefMain ::-     ClassImportHeader-  -> String-buildDefMain cih =-  let classes = [cihClass cih]-      headerStmts =-           [ R.Include "MacroPatternMatch.h" ]-        <> genAllCppHeaderInclude cih-        <> [ R.Include (cihSelfHeader cih) ]-      namespaceStmts =-        (map R.UsingNamespace . cihNamespace) cih-      aclass = cihClass cih-      aliasStr = intercalate "\n" $-                   mapMaybe typedefstmt $-                     aclass : rights (cihImportedClasses cih)-        where typedefstmt c = let n1 = class_name c-                                  n2 = ffiClassName c-                              in if n1 == n2-                                 then Nothing-                                 else Just ("typedef " <> n1 <> " " <> n2 <> ";")--      cppBodyStmts =-           mkProtectedFunctionList (cihClass cih)-        <> map-             R.CRegular-             (   buildParentDef (\(p,c) -> [genCppDefInstVirtual (p,c), R.CEmptyLine])  (cihClass cih)-              <> (if isAbstractClass aclass-                  then []-                  else [genCppDefInstVirtual (aclass, aclass), R.CEmptyLine]-                 )-              <> concatMap (\c -> [genCppDefInstNonVirtual c, R.CEmptyLine]) classes-              <> concatMap (\c -> [genCppDefInstAccessor c, R.CEmptyLine]) classes-             )-  in concatMap R.renderCMacro-       (   headerStmts-        <> [ R.EmptyLine ]-        <> map R.CRegular namespaceStmts-        <> [ R.EmptyLine-           , R.Verbatim aliasStr-           , R.EmptyLine-           , R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n"-           , R.EmptyLine-           , R.Verbatim "#define TYPECASTMETHOD(cname,mname,oname) \\\n\-                        \  FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\-                        \  (from_nonconst_to_nonconst<oname,cname ## _t>), \\\n\-                        \  (from_nonconst_to_nonconst<cname,cname ## _t>) )\n"-           , R.EmptyLine-           ]-        <> cppBodyStmts-       )---- |-buildTopLevelHeader ::-     String     -- ^ C prefix-  -> TopLevelImportHeader-  -> String-buildTopLevelHeader cprefix tih =-  let declHeaderStmts =-           [ R.Include (HdrName (cprefix ++ "Type.h")) ]-        <> map R.Include (map cihSelfHeader (tihClassDep tih) ++ tihExtraHeadersInH tih)-      declBodyStmts = map (R.CDeclaration . topLevelDecl) $ tihFuncs tih-  in R.renderBlock $-       R.ExternC $-            [ R.Pragma R.Once, R.EmptyLine ]-         <> declHeaderStmts-         <> [ R.EmptyLine ]-         <> map R.CRegular declBodyStmts---- |-buildTopLevelCppDef :: TopLevelImportHeader -> String-buildTopLevelCppDef tih =-  let cihs = tihClassDep tih-      extclasses = tihExtraClassDep tih-      declHeaderStmts =-           [ R.Include "MacroPatternMatch.h"-           , R.Include (HdrName (tihHeaderFileName tih <.> "h"))-           ]-        <> concatMap genAllCppHeaderInclude cihs-        <> otherHeaderStmts-      otherHeaderStmts =-        map R.Include (map cihSelfHeader cihs ++ tihExtraHeadersInCPP tih)--      allns = nub ((tihClassDep tih >>= cihNamespace) ++ tihNamespaces tih)--      namespaceStmts = map R.UsingNamespace allns-      aliasStr = intercalate "\n" $-                   mapMaybe typedefstmt $-                     rights (concatMap cihImportedClasses cihs ++ extclasses)-        where typedefstmt c = let n1 = class_name c-                                  n2 = ffiClassName c-                              in if n1 == n2-                                 then Nothing-                                 else Just ("typedef " <> n1 <> " " <> n2 <> ";")-      declBodyStr =-        intercalate "\n" $-          map (R.renderCStmt . genTopLevelCppDefinition) (tihFuncs tih)--  in concatMap R.renderCMacro-       (   declHeaderStmts-        <> [R.EmptyLine]-        <> map R.CRegular namespaceStmts-        <> [ R.EmptyLine-           , R.Verbatim aliasStr-           , R.EmptyLine-           , R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n"-           , R.EmptyLine-           , R.Verbatim "#define TYPECASTMETHOD(cname,mname,oname) \\\n\-                        \  FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\-                        \  (to_nonconst<oname,cname ## _t>), \\\n\-                        \  (to_nonconst<cname,cname ## _t>) )\n"-           , R.EmptyLine-           , R.Verbatim declBodyStr-           ]-       )---- |-buildFFIHsc :: ClassModule -> Module ()-buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody-  where mname = cmModule m-        ffiImports = [ mkImport "Data.Word"-                     , mkImport "Data.Int"-                     , mkImport "Foreign.C"-                     , mkImport "Foreign.Ptr"-                     , mkImport (mname <.> "RawType") ]-                     <> genImportInFFI m-                     <> genExtraImport m-        hscBody = genHsFFI (cmCIH m)----- |-buildRawTypeHs :: ClassModule -> Module ()-buildRawTypeHs m =-    mkModule-      (cmModule m <.> "RawType")-      [ lang-          [ "ForeignFunctionInterface"-          , "TypeFamilies"-          , "MultiParamTypeClasses"-          , "FlexibleInstances"-          , "TypeSynonymInstances"-          , "EmptyDataDecls"-          , "ExistentialQuantification"-          , "ScopedTypeVariables"-          ]-      ]-      rawtypeImports-      rawtypeBody-  where-    rawtypeImports = [ mkImport "Foreign.Ptr"-                     , mkImport "FFICXX.Runtime.Cast"-                     ]-    rawtypeBody = let c = cihClass (cmCIH m)-                  in if isAbstractClass c then [] else hsClassRawType c---- |-buildInterfaceHs :: AnnotateMap -> ClassModule -> Module ()-buildInterfaceHs amap m =-  mkModule-    (cmModule m <.> "Interface")-    [ lang-      [ "EmptyDataDecls"-      , "ExistentialQuantification"-      , "FlexibleContexts"-      , "FlexibleInstances"-      , "ForeignFunctionInterface"-      , "MultiParamTypeClasses"-      , "ScopedTypeVariables"-      , "TypeFamilies"-      , "TypeSynonymInstances"-      ]-    ]-    ifaceImports-    ifaceBody-  where-    classes = [cihClass (cmCIH m)]-    ifaceImports = [ mkImport "Data.Word"-                   , mkImport "Data.Int"-                   , mkImport "Foreign.C"-                   , mkImport "Foreign.Ptr"-                   , mkImport "FFICXX.Runtime.Cast"-                   ]-                   <> genImportInInterface m-                   <> genExtraImport m-    ifaceBody =-         runReader (mapM genHsFrontDecl classes) amap-      <> (concatMap genHsFrontUpcastClass . filter (not.isAbstractClass)) classes-      <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes---- |-buildCastHs :: ClassModule -> Module ()-buildCastHs m = mkModule (cmModule m <.> "Cast")-               [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies"-                      , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ]-               castImports body-  where classes = [ cihClass (cmCIH m) ]-        castImports =    [ mkImport "Foreign.Ptr"-                         , mkImport "FFICXX.Runtime.Cast"-                         , mkImport "System.IO.Unsafe" ]-                      <> genImportInCast m-        body =    mapMaybe genHsFrontInstCastable classes-               <> mapMaybe genHsFrontInstCastableSelf classes---- |-buildImplementationHs :: AnnotateMap -> ClassModule -> Module ()-buildImplementationHs amap m =-    mkModule (cmModule m <.> "Implementation")-      [ lang [ "EmptyDataDecls"-             , "FlexibleContexts"-             , "FlexibleInstances"-             , "ForeignFunctionInterface"-             , "IncoherentInstances"-             , "MultiParamTypeClasses"-             , "OverlappingInstances"-             , "TemplateHaskell"-             , "TypeFamilies"-             , "TypeSynonymInstances"-             ]-      ]-      implImports implBody-  where-    classes = [ cihClass (cmCIH m) ]-    implImports = [ mkImport "Data.Monoid"                -- for template member-                  , mkImport "Data.Word"-                  , mkImport "Data.Int"-                  , mkImport "Foreign.C"-                  , mkImport "Foreign.Ptr"-                  , mkImport "Language.Haskell.TH"        -- for template member-                  , mkImport "Language.Haskell.TH.Syntax" -- for template member-                  , mkImport "System.IO.Unsafe"-                  , mkImport "FFICXX.Runtime.Cast"-                  , mkImport "FFICXX.Runtime.CodeGen.Cxx" -- for template member-                  , mkImport "FFICXX.Runtime.TH"          -- for template member-                  ]-                  <> genImportInImplementation m-                  <> genExtraImport m-    f :: Class -> [Decl ()]-    f y = concatMap (flip genHsFrontInst y) (y:class_allparents y)--    implBody =    concatMap f classes-               <> runReader (concat <$> mapM genHsFrontInstNew classes) amap-               <> concatMap genHsFrontInstNonVirtual classes-               <> concatMap genHsFrontInstStatic classes-               <> concatMap genHsFrontInstVariables classes-               <> genTemplateMemberFunctions (cmCIH m)--buildProxyHs :: ClassModule -> Module ()-buildProxyHs m =-    mkModule (cmModule m <.> "Proxy")-      [ lang [ "FlexibleInstances"-             , "OverloadedStrings"-             , "TemplateHaskell"-             ]-      ]-      [ mkImport "Foreign.Ptr"-      , mkImport "FFICXX.Runtime.Cast"-      , mkImport "Language.Haskell.TH"-      , mkImport "Language.Haskell.TH.Syntax"-      , mkImport "FFICXX.Runtime.CodeGen.Cxx"-      ]-      body-  where-    body = genProxyInstance----buildTemplateHs :: TemplateClassModule -> Module ()-buildTemplateHs m =-    mkModule (tcmModule m <.> "Template")-      [ lang-          [ "EmptyDataDecls"-          , "FlexibleInstances"-          , "MultiParamTypeClasses"-          , "TypeFamilies"-          ]-      ]-      imports-      body-  where-    t = tcihTClass $ tcmTCIH m-    imports =    [ mkImport "Foreign.C.Types"-                 , mkImport "Foreign.Ptr"-                 , mkImport "FFICXX.Runtime.Cast"-                 ]-              <> genImportInTemplate t-    body = genTmplInterface t--buildTHHs :: TemplateClassModule -> Module ()-buildTHHs m =-  mkModule (tcmModule m <.> "TH")-    [ lang  ["TemplateHaskell"] ]-    (   [ mkImport "Data.Char"-        , mkImport "Data.List"-        , mkImport "Data.Monoid"-        , mkImport "Foreign.C.Types"-        , mkImport "Foreign.Ptr"-        , mkImport "Language.Haskell.TH"-        , mkImport "Language.Haskell.TH.Syntax"-        , mkImport "FFICXX.Runtime.CodeGen.Cxx"-        , mkImport "FFICXX.Runtime.TH"-        ]-     <> imports-    )-    body-  where-    t = tcihTClass $ tcmTCIH m-    imports =    [ mkImport (tcmModule m <.> "Template") ]-              <> genImportInTH t-    body = tmplImpls <> tmplInsts-    tmplImpls = genTmplImplementation t-    tmplInsts = genTmplInstance (tcmTCIH m)---- |-buildInterfaceHSBOOT :: String -> Module ()-buildInterfaceHSBOOT mname = mkModule (mname <.> "Interface") [] [] hsbootBody-  where cname = last (splitOn "." mname)-        hsbootBody = [ mkClass cxEmpty ('I':cname) [mkTBind "a"] [] ]---- |-buildModuleHs :: ClassModule -> Module ()-buildModuleHs m = mkModuleE (cmModule m) [] (genExport c) (genImportInModule c) []-  where c = cihClass (cmCIH m)---- |-buildTopLevelHs :: String -> ([ClassModule],[TemplateClassModule]) -> TopLevelImportHeader -> Module ()-buildTopLevelHs modname (mods,tmods) tih =-    mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody-  where-    tfns = tihFuncs tih-    pkgExtensions = [ lang [ "FlexibleContexts", "FlexibleInstances" ] ]-    pkgExports =     map (emodule . cmModule) mods-                 ++  map (evar . unqual . hsFrontNameForTopLevel) tfns--    pkgImports = genImportInTopLevel modname (mods,tmods) tih--    pkgBody    =    map (genTopLevelFFI tih) tfns-                 ++ concatMap genTopLevelDef tfns---- |-buildPackageInterface :: PackageInterface-                      -> PackageName-                      -> [ClassImportHeader]-                      -> PackageInterface-buildPackageInterface pinfc pkgname = foldr f pinfc-  where f cih repo =-          let name = (class_name . cihClass) cih-              header = cihSelfHeader cih-          in repo & at (pkgname,ClsName name) .~ (Just header)+import Control.Lens (at, (&), (.~))+import Control.Monad.Trans.Reader (runReader)+import Data.Either (rights)+import Data.Functor.Identity (Identity)+import Data.List (intercalate, nub)+import qualified Data.Map as M+import Data.Maybe (mapMaybe)+import FFICXX.Generate.Code.Cpp+  ( genAllCppHeaderInclude,+    genCppDefInstAccessor,+    genCppDefInstNonVirtual,+    genCppDefInstVirtual,+    genCppDefMacroAccessor,+    genCppDefMacroNonVirtual,+    genCppDefMacroTemplateMemberFunction,+    genCppDefMacroVirtual,+    genCppHeaderInstAccessor,+    genCppHeaderInstNonVirtual,+    genCppHeaderInstVirtual,+    genCppHeaderMacroAccessor,+    genCppHeaderMacroNonVirtual,+    genCppHeaderMacroType,+    genCppHeaderMacroVirtual,+    genTopLevelCppDefinition,+    topLevelDecl,+  )+import FFICXX.Generate.Code.HsCast+  ( genHsFrontInstCastable,+    genHsFrontInstCastableSelf,+  )+import FFICXX.Generate.Code.HsFFI+  ( genHsFFI,+    genImportInFFI,+    genTopLevelFFI,+  )+import FFICXX.Generate.Code.HsFrontEnd+  ( genExport,+    genExtraImport,+    genHsFrontDecl,+    genHsFrontDowncastClass,+    genHsFrontInst,+    genHsFrontInstNew,+    genHsFrontInstNonVirtual,+    genHsFrontInstStatic,+    genHsFrontInstVariables,+    genHsFrontUpcastClass,+    genImportForTLOrdinary,+    genImportForTLTemplate,+    genImportInCast,+    genImportInImplementation,+    genImportInInterface,+    genImportInModule,+    genImportInTopLevel,+    genTopLevelDef,+    hsClassRawType,+  )+import FFICXX.Generate.Code.HsProxy (genProxyInstance)+import FFICXX.Generate.Code.HsTemplate+  ( genImportInTH,+    genImportInTemplate,+    genTLTemplateImplementation,+    genTLTemplateInstance,+    genTLTemplateInterface,+    genTemplateMemberFunctions,+    genTmplImplementation,+    genTmplInstance,+    genTmplInterface,+  )+import FFICXX.Generate.Dependency+  ( class_allparents,+    mkDaughterMap,+    mkDaughterSelfMap,+  )+import FFICXX.Generate.Name+  ( ffiClassName,+    hsClassName,+    hsFrontNameForTopLevel,+  )+import FFICXX.Generate.Type.Annotate (AnnotateMap)+import FFICXX.Generate.Type.Class+  ( Class (..),+    ClassGlobal (..),+    DaughterMap,+    ProtectedMethod (..),+    TopLevel (TLOrdinary, TLTemplate),+    filterTLOrdinary,+    filterTLTemplate,+    isAbstractClass,+  )+import FFICXX.Generate.Type.Module+  ( ClassImportHeader (..),+    ClassModule (..),+    DepCycles,+    TemplateClassImportHeader (..),+    TemplateClassModule (..),+    TopLevelImportHeader (..),+  )+import FFICXX.Generate.Type.PackageInterface+  ( ClassName (..),+    PackageInterface,+    PackageName (..),+  )+import FFICXX.Generate.Util (firstUpper)+import FFICXX.Generate.Util.HaskellSrcExts+  ( emodule,+    evar,+    lang,+    mkImport,+    mkModule,+    mkModuleE,+    unqual,+  )+import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))+import qualified FFICXX.Runtime.CodeGen.Cxx as R+import Language.Haskell.Exts.Syntax+  ( Decl (..),+    EWildcard (EWildcard),+    ExportSpec (EThingWith),+    Module (..),+  )+import System.FilePath ((<.>), (</>))++srcDir :: FilePath -> FilePath+srcDir installbasedir = installbasedir </> "src"++csrcDir :: FilePath -> FilePath+csrcDir installbasedir = installbasedir </> "csrc"++---- common function for daughter++-- |+mkGlobal :: [Class] -> ClassGlobal+mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap++-- |+buildDaughterDef ::+  ((String, [Class]) -> String) ->+  DaughterMap ->+  String+buildDaughterDef f m =+  let lst = M.toList m+      f' (x, xs) = f (x, filter (not . isAbstractClass) xs)+   in (concatMap f' lst)++-- |+buildParentDef :: ((Class, Class) -> [R.CStatement Identity]) -> Class -> [R.CStatement Identity]+buildParentDef f cls = concatMap (\p -> f (p, cls)) . class_allparents $ cls++-- |+mkProtectedFunctionList :: Class -> [R.CMacro Identity]+mkProtectedFunctionList c =+  map (\x -> R.Define (R.sname ("IS_" <> class_name c <> "_" <> x <> "_PROTECTED")) [] [R.CVerbatim "()"])+    . unProtected+    . class_protected+    $ c++-- |+buildTypeDeclHeader ::+  [Class] ->+  String+buildTypeDeclHeader classes =+  let typeDeclBodyStmts =+        intercalate [R.EmptyLine] $+          map (map R.CRegular . genCppHeaderMacroType) classes+   in R.renderBlock $+        R.ExternC $+          [R.Pragma R.Once, R.EmptyLine] <> typeDeclBodyStmts++-- |+buildDeclHeader ::+  -- | C prefix+  String ->+  ClassImportHeader ->+  String+buildDeclHeader cprefix header =+  let classes = [cihClass header]+      aclass = cihClass header+      declHeaderStmts =+        [R.Include (HdrName (cprefix ++ "Type.h"))]+          <> map R.Include (cihIncludedHPkgHeadersInH header)+      vdecl = map genCppHeaderMacroVirtual classes+      nvdecl = map genCppHeaderMacroNonVirtual classes+      acdecl = map genCppHeaderMacroAccessor classes+      vdef = map genCppDefMacroVirtual classes+      nvdef = map genCppDefMacroNonVirtual classes+      acdef = map genCppDefMacroAccessor classes+      tmpldef = map (\c -> map (genCppDefMacroTemplateMemberFunction c) (class_tmpl_funcs c)) classes+      declDefStmts =+        intercalate [R.EmptyLine] $ [vdecl, nvdecl, acdecl, vdef, nvdef, acdef] ++ tmpldef+      classDeclStmts =+        -- NOTE: Deletable is treated specially.+        -- TODO: We had better make it as a separate constructor in Class.+        if (fst . hsClassName) aclass /= "Deletable"+          then+            buildParentDef (\(p, c) -> [genCppHeaderInstVirtual (p, c), R.CEmptyLine]) aclass+              <> [genCppHeaderInstVirtual (aclass, aclass), R.CEmptyLine]+              <> concatMap (\c -> [genCppHeaderInstNonVirtual c, R.CEmptyLine]) classes+              <> concatMap (\c -> [genCppHeaderInstAccessor c, R.CEmptyLine]) classes+          else []+   in R.renderBlock $+        R.ExternC $+          [R.Pragma R.Once, R.EmptyLine]+            <> declHeaderStmts+            <> [R.EmptyLine]+            <> declDefStmts+            <> [R.EmptyLine]+            <> map R.CRegular classDeclStmts++-- |+buildDefMain ::+  ClassImportHeader ->+  String+buildDefMain cih =+  let classes = [cihClass cih]+      headerStmts =+        [R.Include "MacroPatternMatch.h"]+          <> genAllCppHeaderInclude cih+          <> [R.Include (cihSelfHeader cih)]+      namespaceStmts =+        (map R.UsingNamespace . cihNamespace) cih+      aclass = cihClass cih+      aliasStr =+        intercalate "\n" $+          mapMaybe typedefstmt $+            aclass : rights (cihImportedClasses cih)+        where+          typedefstmt c =+            let n1 = class_name c+                n2 = ffiClassName c+             in if n1 == n2+                  then Nothing+                  else Just ("typedef " <> n1 <> " " <> n2 <> ";")+      cppBodyStmts =+        mkProtectedFunctionList (cihClass cih)+          <> map+            R.CRegular+            ( buildParentDef (\(p, c) -> [genCppDefInstVirtual (p, c), R.CEmptyLine]) (cihClass cih)+                <> ( if isAbstractClass aclass+                       then []+                       else [genCppDefInstVirtual (aclass, aclass), R.CEmptyLine]+                   )+                <> concatMap (\c -> [genCppDefInstNonVirtual c, R.CEmptyLine]) classes+                <> concatMap (\c -> [genCppDefInstAccessor c, R.CEmptyLine]) classes+            )+   in concatMap+        R.renderCMacro+        ( headerStmts+            <> [R.EmptyLine]+            <> map R.CRegular namespaceStmts+            <> [ R.EmptyLine,+                 R.Verbatim aliasStr,+                 R.EmptyLine,+                 R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n",+                 R.EmptyLine,+                 R.Verbatim+                   "#define TYPECASTMETHOD(cname,mname,oname) \\\n\+                   \  FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\+                   \  (from_nonconst_to_nonconst<oname,cname ## _t>), \\\n\+                   \  (from_nonconst_to_nonconst<cname,cname ## _t>) )\n",+                 R.EmptyLine+               ]+            <> cppBodyStmts+        )++-- |+buildTopLevelHeader ::+  -- | C prefix+  String ->+  TopLevelImportHeader ->+  String+buildTopLevelHeader cprefix tih =+  let declHeaderStmts =+        [R.Include (HdrName (cprefix ++ "Type.h"))]+          <> map R.Include (map cihSelfHeader (tihClassDep tih) ++ tihExtraHeadersInH tih)+      declBodyStmts = map (R.CDeclaration . topLevelDecl) $ filterTLOrdinary (tihFuncs tih)+   in R.renderBlock $+        R.ExternC $+          [R.Pragma R.Once, R.EmptyLine]+            <> declHeaderStmts+            <> [R.EmptyLine]+            <> map R.CRegular declBodyStmts++-- |+buildTopLevelCppDef :: TopLevelImportHeader -> String+buildTopLevelCppDef tih =+  let cihs = tihClassDep tih+      extclasses = tihExtraClassDep tih+      declHeaderStmts =+        [ R.Include "MacroPatternMatch.h",+          R.Include (HdrName (tihHeaderFileName tih <.> "h"))+        ]+          <> concatMap genAllCppHeaderInclude cihs+          <> otherHeaderStmts+      otherHeaderStmts =+        map R.Include (map cihSelfHeader cihs ++ tihExtraHeadersInCPP tih)+      allns = nub ((tihClassDep tih >>= cihNamespace) ++ tihNamespaces tih)+      namespaceStmts = map R.UsingNamespace allns+      aliasStr =+        intercalate "\n" $+          mapMaybe typedefstmt $+            rights (concatMap cihImportedClasses cihs ++ extclasses)+        where+          typedefstmt c =+            let n1 = class_name c+                n2 = ffiClassName c+             in if n1 == n2+                  then Nothing+                  else Just ("typedef " <> n1 <> " " <> n2 <> ";")+      declBodyStr =+        intercalate "\n" $+          map (R.renderCStmt . genTopLevelCppDefinition) $+            filterTLOrdinary (tihFuncs tih)+   in concatMap+        R.renderCMacro+        ( declHeaderStmts+            <> [R.EmptyLine]+            <> map R.CRegular namespaceStmts+            <> [ R.EmptyLine,+                 R.Verbatim aliasStr,+                 R.EmptyLine,+                 R.Verbatim "#define CHECKPROTECT(x,y) FXIS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n",+                 R.EmptyLine,+                 R.Verbatim+                   "#define TYPECASTMETHOD(cname,mname,oname) \\\n\+                   \  FXIIF( CHECKPROTECT(cname,mname) ) ( \\\n\+                   \  (to_nonconst<oname,cname ## _t>), \\\n\+                   \  (to_nonconst<cname,cname ## _t>) )\n",+                 R.EmptyLine,+                 R.Verbatim declBodyStr+               ]+        )++-- |+buildFFIHsc :: ClassModule -> Module ()+buildFFIHsc m =+  mkModule+    (mname <.> "FFI")+    [lang ["ForeignFunctionInterface", "InterruptibleFFI"]]+    ffiImports+    hscBody+  where+    mname = cmModule m+    ffiImports =+      [ mkImport "Data.Word",+        mkImport "Data.Int",+        mkImport "Foreign.C",+        mkImport "Foreign.Ptr",+        mkImport (mname <.> "RawType")+      ]+        <> genImportInFFI m+        <> genExtraImport m+    hscBody = genHsFFI (cmCIH m)++-- |+buildRawTypeHs :: ClassModule -> Module ()+buildRawTypeHs m =+  mkModule+    (cmModule m <.> "RawType")+    [ lang+        [ "ForeignFunctionInterface",+          "TypeFamilies",+          "MultiParamTypeClasses",+          "FlexibleInstances",+          "TypeSynonymInstances",+          "EmptyDataDecls",+          "ExistentialQuantification",+          "ScopedTypeVariables"+        ]+    ]+    rawtypeImports+    rawtypeBody+  where+    rawtypeImports =+      [ mkImport "Foreign.Ptr",+        mkImport "FFICXX.Runtime.Cast"+      ]+    rawtypeBody =+      let c = cihClass (cmCIH m)+       in if isAbstractClass c then [] else hsClassRawType c++-- |+buildInterfaceHs ::+  AnnotateMap ->+  DepCycles ->+  ClassModule ->+  Module ()+buildInterfaceHs amap depCycles m =+  mkModule+    (cmModule m <.> "Interface")+    [ lang+        [ "EmptyDataDecls",+          "ExistentialQuantification",+          "FlexibleContexts",+          "FlexibleInstances",+          "ForeignFunctionInterface",+          "MultiParamTypeClasses",+          "ScopedTypeVariables",+          "TypeFamilies",+          "TypeSynonymInstances"+        ]+    ]+    ifaceImports+    ifaceBody+  where+    classes = [cihClass (cmCIH m)]+    ifaceImports =+      [ mkImport "Data.Word",+        mkImport "Data.Int",+        mkImport "Foreign.C",+        mkImport "Foreign.Ptr",+        mkImport "FFICXX.Runtime.Cast"+      ]+        <> genImportInInterface False depCycles m+        <> genExtraImport m+    ifaceBody =+      runReader (mapM (genHsFrontDecl False) classes) amap+        <> (concatMap genHsFrontUpcastClass . filter (not . isAbstractClass)) classes+        <> (concatMap genHsFrontDowncastClass . filter (not . isAbstractClass)) classes++-- |+buildInterfaceHsBoot :: DepCycles -> ClassModule -> Module ()+buildInterfaceHsBoot depCycles m =+  mkModule+    (cmModule m <.> "Interface")+    [ lang+        [ "EmptyDataDecls",+          "ExistentialQuantification",+          "FlexibleContexts",+          "FlexibleInstances",+          "ForeignFunctionInterface",+          "MultiParamTypeClasses",+          "ScopedTypeVariables",+          "TypeFamilies",+          "TypeSynonymInstances"+        ]+    ]+    hsbootImports+    hsbootBody+  where+    c = cihClass (cmCIH m)+    hsbootImports =+      [ mkImport "Data.Word",+        mkImport "Data.Int",+        mkImport "Foreign.C",+        mkImport "Foreign.Ptr",+        mkImport "FFICXX.Runtime.Cast"+      ]+        <> genImportInInterface True depCycles m+        <> genExtraImport m+    hsbootBody =+      runReader (mapM (genHsFrontDecl True) [c]) M.empty++-- |+buildCastHs :: ClassModule -> Module ()+buildCastHs m =+  mkModule+    (cmModule m <.> "Cast")+    [ lang+        [ "FlexibleInstances",+          "FlexibleContexts",+          "TypeFamilies",+          "MultiParamTypeClasses",+          "OverlappingInstances",+          "IncoherentInstances"+        ]+    ]+    castImports+    body+  where+    classes = [cihClass (cmCIH m)]+    castImports =+      [ mkImport "Foreign.Ptr",+        mkImport "FFICXX.Runtime.Cast",+        mkImport "System.IO.Unsafe"+      ]+        <> genImportInCast m+    body =+      mapMaybe genHsFrontInstCastable classes+        <> mapMaybe genHsFrontInstCastableSelf classes++-- |+buildImplementationHs :: AnnotateMap -> ClassModule -> Module ()+buildImplementationHs amap m =+  mkModule+    (cmModule m <.> "Implementation")+    [ lang+        [ "EmptyDataDecls",+          "FlexibleContexts",+          "FlexibleInstances",+          "ForeignFunctionInterface",+          "IncoherentInstances",+          "MultiParamTypeClasses",+          "OverlappingInstances",+          "TemplateHaskell",+          "TypeFamilies",+          "TypeSynonymInstances"+        ]+    ]+    implImports+    implBody+  where+    classes = [cihClass (cmCIH m)]+    implImports =+      [ mkImport "Data.Monoid", -- for template member+        mkImport "Data.Word",+        mkImport "Data.Int",+        mkImport "Foreign.C",+        mkImport "Foreign.Ptr",+        mkImport "Language.Haskell.TH", -- for template member+        mkImport "Language.Haskell.TH.Syntax", -- for template member+        mkImport "System.IO.Unsafe",+        mkImport "FFICXX.Runtime.Cast",+        mkImport "FFICXX.Runtime.CodeGen.Cxx", -- for template member+        mkImport "FFICXX.Runtime.TH" -- for template member+      ]+        <> genImportInImplementation m+        <> genExtraImport m+    f :: Class -> [Decl ()]+    f y = concatMap (flip genHsFrontInst y) (y : class_allparents y)+    implBody =+      concatMap f classes+        <> runReader (concat <$> mapM genHsFrontInstNew classes) amap+        <> concatMap genHsFrontInstNonVirtual classes+        <> concatMap genHsFrontInstStatic classes+        <> concatMap genHsFrontInstVariables classes+        <> genTemplateMemberFunctions (cmCIH m)++buildProxyHs :: ClassModule -> Module ()+buildProxyHs m =+  mkModule+    (cmModule m <.> "Proxy")+    [ lang+        [ "FlexibleInstances",+          "OverloadedStrings",+          "TemplateHaskell"+        ]+    ]+    [ mkImport "Foreign.Ptr",+      mkImport "FFICXX.Runtime.Cast",+      mkImport "Language.Haskell.TH",+      mkImport "Language.Haskell.TH.Syntax",+      mkImport "FFICXX.Runtime.CodeGen.Cxx"+    ]+    body+  where+    body = genProxyInstance++buildTemplateHs :: TemplateClassModule -> Module ()+buildTemplateHs m =+  mkModule+    (tcmModule m <.> "Template")+    [ lang+        [ "EmptyDataDecls",+          "FlexibleInstances",+          "MultiParamTypeClasses",+          "TypeFamilies"+        ]+    ]+    imports+    body+  where+    t = tcihTClass $ tcmTCIH m+    imports =+      [ mkImport "Foreign.C.Types",+        mkImport "Foreign.Ptr",+        mkImport "FFICXX.Runtime.Cast"+      ]+        <> genImportInTemplate t+    body = genTmplInterface t++buildTHHs :: TemplateClassModule -> Module ()+buildTHHs m =+  mkModule+    (tcmModule m <.> "TH")+    [lang ["TemplateHaskell"]]+    ( [ mkImport "Data.Char",+        mkImport "Data.List",+        mkImport "Data.Monoid",+        mkImport "Foreign.C.Types",+        mkImport "Foreign.Ptr",+        mkImport "Language.Haskell.TH",+        mkImport "Language.Haskell.TH.Syntax",+        mkImport "FFICXX.Runtime.CodeGen.Cxx",+        mkImport "FFICXX.Runtime.TH"+      ]+        <> imports+    )+    body+  where+    t = tcihTClass $ tcmTCIH m+    imports =+      [mkImport (tcmModule m <.> "Template")]+        <> genImportInTH t+    body = tmplImpls <> tmplInsts+    tmplImpls = genTmplImplementation t+    tmplInsts = genTmplInstance (tcmTCIH m)++-- |+buildModuleHs :: ClassModule -> Module ()+buildModuleHs m = mkModuleE (cmModule m) [] (genExport c) (genImportInModule c) []+  where+    c = cihClass (cmCIH m)++-- |+buildTopLevelHs ::+  String ->+  ([ClassModule], [TemplateClassModule]) ->+  Module ()+buildTopLevelHs modname (mods, tmods) =+  mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody+  where+    pkgExtensions =+      [ lang+          [ "FlexibleContexts",+            "FlexibleInstances",+            "ForeignFunctionInterface",+            "InterruptibleFFI"+          ]+      ]+    pkgExports =+      map (emodule . cmModule) mods+        ++ map emodule [modname <.> "Ordinary", modname <.> "Template", modname <.> "TH"]+    pkgImports = genImportInTopLevel modname (mods, tmods)+    pkgBody = [] --    map (genTopLevelFFI tih) (filterTLOrdinary tfns)+    -- ++ concatMap genTopLevelDef (filterTLOrdinary tfns)++buildTopLevelOrdinaryHs ::+  String ->+  ([ClassModule], [TemplateClassModule]) ->+  TopLevelImportHeader ->+  Module ()+buildTopLevelOrdinaryHs modname (_mods, tmods) tih =+  mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody+  where+    tfns = tihFuncs tih+    pkgExtensions =+      [ lang+          [ "FlexibleContexts",+            "FlexibleInstances",+            "ForeignFunctionInterface",+            "InterruptibleFFI"+          ]+      ]+    pkgExports = map (evar . unqual . hsFrontNameForTopLevel . TLOrdinary) (filterTLOrdinary tfns)+    pkgImports =+      map mkImport ["Foreign.C", "Foreign.Ptr", "FFICXX.Runtime.Cast"]+        ++ map (\m -> mkImport (tcmModule m <.> "Template")) tmods+        ++ concatMap genImportForTLOrdinary (filterTLOrdinary tfns)+    pkgBody =+      map (genTopLevelFFI tih) (filterTLOrdinary tfns)+        ++ concatMap genTopLevelDef (filterTLOrdinary tfns)++-- |+buildTopLevelTemplateHs ::+  String ->+  TopLevelImportHeader ->+  Module ()+buildTopLevelTemplateHs modname tih =+  mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody+  where+    tfns = filterTLTemplate (tihFuncs tih)+    pkgExtensions =+      [ lang+          [ "EmptyDataDecls",+            "FlexibleInstances",+            "ForeignFunctionInterface",+            "InterruptibleFFI",+            "MultiParamTypeClasses",+            "TypeFamilies"+          ]+      ]+    pkgExports =+      map+        ( (\n -> EThingWith () (EWildcard () 1) n [])+            . unqual+            . firstUpper+            . hsFrontNameForTopLevel+            . TLTemplate+        )+        tfns+    pkgImports =+      [ mkImport "Foreign.C.Types",+        mkImport "Foreign.Ptr",+        mkImport "FFICXX.Runtime.Cast"+      ]+        ++ concatMap genImportForTLTemplate tfns+    pkgBody = concatMap genTLTemplateInterface tfns++-- |+buildTopLevelTHHs ::+  String ->+  TopLevelImportHeader ->+  Module ()+buildTopLevelTHHs modname tih =+  mkModuleE modname pkgExtensions pkgExports pkgImports pkgBody+  where+    tfns = filterTLTemplate (tihFuncs tih)+    pkgExtensions =+      [ lang+          [ "FlexibleContexts",+            "FlexibleInstances",+            "ForeignFunctionInterface",+            "InterruptibleFFI",+            "TemplateHaskell"+          ]+      ]+    pkgExports =+      map+        ( evar+            . unqual+            . (\x -> "gen" <> x <> "InstanceFor")+            . firstUpper+            . hsFrontNameForTopLevel+            . TLTemplate+        )+        tfns+    pkgImports =+      [ mkImport "Data.Char",+        mkImport "Data.List",+        mkImport "Data.Monoid",+        mkImport "Foreign.C.Types",+        mkImport "Foreign.Ptr",+        mkImport "Language.Haskell.TH",+        mkImport "Language.Haskell.TH.Syntax",+        mkImport "FFICXX.Runtime.CodeGen.Cxx",+        mkImport "FFICXX.Runtime.TH"+      ]+        ++ concatMap genImportForTLTemplate tfns+    pkgBody =+      concatMap genTLTemplateImplementation tfns+        <> concatMap (genTLTemplateInstance tih) tfns++-- |+buildPackageInterface ::+  PackageInterface ->+  PackageName ->+  [ClassImportHeader] ->+  PackageInterface+buildPackageInterface pinfc pkgname = foldr f pinfc+  where+    f cih repo =+      let name = (class_name . cihClass) cih+          header = cihSelfHeader cih+       in repo & at (pkgname, ClsName name) .~ (Just header)

@@ -1,5 +1,6 @@-{-# LANGUAGE LambdaCase      #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}  module FFICXX.Generate.Dependency where @@ -19,50 +20,66 @@ -- dependency class list and finally get the import list for the module corresponding to -- a given class. -import           Data.Either       ( rights )-import           Data.Function     ( on )+import Data.Bifunctor (bimap)+import Data.Either (rights)+import Data.Function (on) import qualified Data.HashMap.Strict as HM-import           Data.List         ( find, foldl', nub, nubBy )+import qualified Data.List as L (find, foldl', nub, nubBy) import qualified Data.Map as M-import           Data.Maybe        ( catMaybes, fromMaybe, mapMaybe )-import           Data.Monoid       ( (<>) )-import           System.FilePath   ( (<.>) )----import FFICXX.Runtime.CodeGen.Cxx  ( HeaderName(..) )----import FFICXX.Generate.Name        ( ffiClassName, hsClassName, hsTemplateClassName )-import FFICXX.Generate.Type.Cabal  ( AddCInc,AddCSrc,CabalName(..)-                                   , cabal_moduleprefix, cabal_pkgname-                                   , cabal_cheaderprefix, unCabalName-                                   )-import FFICXX.Generate.Type.Class  ( Arg(..)-                                   , Class(..)-                                   , CPPTypes(..)-                                   , DaughterMap-                                   , Function(..)-                                   , TemplateAppInfo(..)-                                   , TemplateArgType(TArg_Class)-                                   , TemplateClass(..)-                                   , TemplateFunction(..)-                                   , TemplateMemberFunction(..)-                                   , TopLevel(..)-                                   , Types(..)-                                   , Variable(unVariable)-                                   , argsFromOpExp-                                   )-import FFICXX.Generate.Type.Config ( ModuleUnit(..)-                                   , ModuleUnitImports(..)-                                   , emptyModuleUnitImports-                                   , ModuleUnitMap(..)-                                   )-import FFICXX.Generate.Type.Module ( ClassImportHeader(..)-                                   , ClassModule(..)-                                   , PackageConfig(..)-                                   , TemplateClassImportHeader(..)-                                   , TemplateClassModule(..)-                                   , TopLevelImportHeader(..)-                                   )-+import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import FFICXX.Generate.Name+  ( ffiClassName,+    getClassModuleBase,+    getTClassModuleBase,+    hsClassName,+  )+import FFICXX.Generate.Type.Cabal+  ( AddCInc,+    AddCSrc,+    CabalName (..),+    cabal_cheaderprefix,+    cabal_pkgname,+    unCabalName,+  )+import FFICXX.Generate.Type.Class+  ( Arg (..),+    CPPTypes (..),+    Class (..),+    DaughterMap,+    Function (..),+    TLOrdinary (..),+    TLTemplate (..),+    TemplateAppInfo (..),+    TemplateArgType (TArg_Class),+    TemplateClass (..),+    TemplateFunction (..),+    TemplateMemberFunction (..),+    TopLevel (..),+    Types (..),+    Variable (unVariable),+    argsFromOpExp,+    filterTLOrdinary,+    virtualFuncs,+  )+import FFICXX.Generate.Type.Config+  ( ModuleUnit (..),+    ModuleUnitImports (..),+    ModuleUnitMap (..),+    emptyModuleUnitImports,+  )+import FFICXX.Generate.Type.Module+  ( ClassImportHeader (..),+    ClassModule (..),+    ClassSubmoduleType (..),+    PackageConfig (..),+    TemplateClassImportHeader (..),+    TemplateClassModule (..),+    TemplateClassSubmoduleType (..),+    TopLevelImportHeader (..),+    UClassSubmodule,+  )+import FFICXX.Runtime.CodeGen.Cxx (HeaderName (..))+import System.FilePath ((<.>))  -- utility functions @@ -73,98 +90,91 @@ -- TODO: replace tclass_name with appropriate FFI name when supported. getFFIName = either tclass_name ffiClassName - getPkgName :: Either TemplateClass Class -> CabalName getPkgName = cabal_pkgname . getcabal - -- | extractClassFromType :: Types -> [Either TemplateClass Class]-extractClassFromType Void                     = []-extractClassFromType SelfType                 = []-extractClassFromType (CT _ _)                 = []-extractClassFromType (CPT (CPTClass c) _)     = [Right c]-extractClassFromType (CPT (CPTClassRef c) _)  = [Right c]+extractClassFromType Void = []+extractClassFromType SelfType = []+extractClassFromType (CT _ _) = []+extractClassFromType (CPT (CPTClass c) _) = [Right c]+extractClassFromType (CPT (CPTClassRef c) _) = [Right c] extractClassFromType (CPT (CPTClassCopy c) _) = [Right c] extractClassFromType (CPT (CPTClassMove c) _) = [Right c] extractClassFromType (TemplateApp (TemplateAppInfo t ps _)) =   Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps)-extractClassFromType (TemplateAppRef (TemplateAppInfo t ps _))   =+extractClassFromType (TemplateAppRef (TemplateAppInfo t ps _)) =   Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps)-extractClassFromType (TemplateAppMove (TemplateAppInfo t ps _))   =+extractClassFromType (TemplateAppMove (TemplateAppInfo t ps _)) =   Left t : (map Right $ mapMaybe (\case TArg_Class c -> Just c; _ -> Nothing) ps)-extractClassFromType (TemplateType t)         = [Left t]-extractClassFromType (TemplateParam _)        = []+extractClassFromType (TemplateType t) = [Left t]+extractClassFromType (TemplateParam _) = [] extractClassFromType (TemplateParamPointer _) = []  classFromArg :: Arg -> [Either TemplateClass Class] classFromArg = extractClassFromType . arg_type - class_allparents :: Class -> [Class]-class_allparents c = let ps = class_parents c-                     in  if null ps-                           then []-                           else nub (ps <> (concatMap class_allparents ps))---getClassModuleBase :: Class -> String-getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName)--getTClassModuleBase :: TemplateClass -> String-getTClassModuleBase = (<.>) <$> (cabal_moduleprefix.tclass_cabal) <*> (fst.hsTemplateClassName)-+class_allparents c =+  let ps = class_parents c+   in if null ps+        then []+        else L.nub (ps <> (concatMap class_allparents ps))  -- | Daughter map not including itself mkDaughterMap :: [Class] -> DaughterMap mkDaughterMap = foldl mkDaughterMapWorker M.empty-  where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)-                                  in  foldl (addmeToYourDaughterList c) m ps-        addmeToYourDaughterList c m p = let f Nothing = Just [c]-                                            f (Just cs)  = Just (c:cs)-                                        in  M.alter f p m--+  where+    mkDaughterMapWorker m c =+      let ps = map getClassModuleBase (class_allparents c)+       in foldl (addmeToYourDaughterList c) m ps+    addmeToYourDaughterList c m p =+      let f Nothing = Just [c]+          f (Just cs) = Just (c : cs)+       in M.alter f p m  -- | Daughter Map including itself as a daughter mkDaughterSelfMap :: [Class] -> DaughterMap-mkDaughterSelfMap = foldl' worker M.empty-  where worker m c = let ps = map getClassModuleBase (c:class_allparents c)-                     in  foldl (addToList c) m ps-        addToList c m p = let f Nothing = Just [c]-                              f (Just cs)  = Just (c:cs)-                          in  M.alter f p m--+mkDaughterSelfMap = L.foldl' worker M.empty+  where+    worker m c =+      let ps = map getClassModuleBase (c : class_allparents c)+       in foldl (addToList c) m ps+    addToList c m p =+      let f Nothing = Just [c]+          f (Just cs) = Just (c : cs)+       in M.alter f p m  -- | class dependency for a given function-data Dep4Func = Dep4Func { returnDependency :: [Either TemplateClass Class]-                         , argumentDependency :: [Either TemplateClass Class] }-+data Dep4Func = Dep4Func+  { returnDependency :: [Either TemplateClass Class],+    argumentDependency :: [Either TemplateClass Class]+  }  -- | extractClassDep :: Function -> Dep4Func-extractClassDep (Constructor args _)  =-    Dep4Func [] (concatMap classFromArg args)+extractClassDep (Constructor args _) =+  Dep4Func [] (concatMap classFromArg args) extractClassDep (Virtual ret _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap classFromArg args)+  Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (NonVirtual ret _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap classFromArg args)+  Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (Static ret _ args _) =-    Dep4Func (extractClassFromType ret) (concatMap classFromArg args)+  Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDep (Destructor _) =-    Dep4Func [] []+  Dep4Func [] []  -- | extractClassDepForTmplFun :: TemplateFunction -> Dep4Func-extractClassDepForTmplFun (TFun ret  _ _ args) =-    Dep4Func (extractClassFromType ret) (concatMap classFromArg args)+extractClassDepForTmplFun (TFun ret _ _ args) =+  Dep4Func (extractClassFromType ret) (concatMap classFromArg args) extractClassDepForTmplFun (TFunNew args _) =-    Dep4Func [] (concatMap classFromArg args)+  Dep4Func [] (concatMap classFromArg args) extractClassDepForTmplFun TFunDelete =-    Dep4Func [] []-extractClassDepForTmplFun (TFunOp ret  _ e) =-    Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e)+  Dep4Func [] []+extractClassDepForTmplFun (TFunOp ret _ e) =+  Dep4Func (extractClassFromType ret) (concatMap classFromArg $ argsFromOpExp e)  -- | extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func@@ -172,140 +182,192 @@   Dep4Func (extractClassFromType tmf_ret) (concatMap classFromArg tmf_args)  -- |-extractClassDepForTopLevel :: TopLevel -> Dep4Func-extractClassDepForTopLevel f =-    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) args)-  where ret = case f of-                TopLevelFunction {..} -> toplevelfunc_ret-                TopLevelVariable {..} -> toplevelvar_ret-        args = case f of-                 TopLevelFunction {..} -> toplevelfunc_args-                 TopLevelVariable {..} -> []+extractClassDepForTLOrdinary :: TLOrdinary -> Dep4Func+extractClassDepForTLOrdinary f =+  Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) args)+  where+    ret = case f of+      TopLevelFunction {..} -> toplevelfunc_ret+      TopLevelVariable {..} -> toplevelvar_ret+    args = case f of+      TopLevelFunction {..} -> toplevelfunc_args+      TopLevelVariable {} -> [] +-- |+extractClassDepForTLTemplate :: TLTemplate -> Dep4Func+extractClassDepForTLTemplate f =+  Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType . arg_type) args)+  where+    ret = topleveltfunc_ret f+    args = topleveltfunc_args f --- TODO: Confirm the answer below is correct.--- NOTE: Q: Why returnDependency only?+mkDepFFI :: Class -> [UClassSubmodule]+mkDepFFI cls =+  let ps = map Right (class_allparents cls)+      alldeps' = concatMap go ps <> go (Right cls)+      depSelf = Right (CSTRawType, cls)+   in depSelf : (fmap (bimap (TCSTTemplate,) (CSTRawType,)) $ L.nub $ filter (/= Right cls) alldeps')+  where+    go (Right c) =+      let fs = class_funcs c+          vs = class_vars c+          tmfs = class_tmpl_funcs c+       in concatMap (returnDependency . extractClassDep) fs+            <> concatMap (argumentDependency . extractClassDep) fs+            <> concatMap (classFromArg . unVariable) vs+            <> concatMap (returnDependency . extractClassDep4TmplMemberFun) tmfs+            <> concatMap (argumentDependency . extractClassDep4TmplMemberFun) tmfs+    go (Left t) =+      let fs = tclass_funcs t+       in concatMap (returnDependency . extractClassDepForTmplFun) fs+            <> concatMap (argumentDependency . extractClassDepForTmplFun) fs++-- For raws:+-- NOTE: Q: Why returnDependency for RawTypes? --       A: Difference between argument and return: --          for a member function f, --          we have (f :: (IA a, IB b) => a -> b -> IO C --          return class is concrete and argument class is constraint.-mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepRaw x@(Right c) =-  nub $-    filter (/= x) $-         concatMap (returnDependency . extractClassDep) (class_funcs c)-      ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)-mkModuleDepRaw x@(Left t) =-  (nub . filter (/= x) . concatMap (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t+calculateDependency :: UClassSubmodule -> [UClassSubmodule]+calculateDependency (Left (typ, tcl)) = raws <> inplaces+  where+    raws' =+      L.nub $+        filter (/= Left tcl) $+          concatMap (returnDependency . extractClassDepForTmplFun) $+            tclass_funcs tcl+    raws =+      case typ of+        TCSTTemplate ->+          fmap (bimap (TCSTTemplate,) (CSTRawType,)) raws'+        TCSTTH ->+          concatMap+            ( \case+                Left t -> [Left (TCSTTemplate, t)]+                Right c -> fmap (Right . (,c)) [CSTRawType, CSTCast, CSTInterface]+            )+            raws'+    inplaces =+      let fs = tclass_funcs tcl+       in fmap (bimap (TCSTTemplate,) (CSTInterface,)) $+            L.nub $+              filter (`isInSamePackageButNotInheritedBy` Left tcl) $+                concatMap (argumentDependency . extractClassDepForTmplFun) fs+calculateDependency (Right (CSTRawType, _)) = []+calculateDependency (Right (CSTFFI, cls)) = mkDepFFI cls+calculateDependency (Right (CSTInterface, cls)) =+  let retDepClasses =+        concatMap (returnDependency . extractClassDep) (virtualFuncs $ class_funcs cls)+          ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs cls)+      argDepClasses =+        concatMap (argumentDependency . extractClassDep) (virtualFuncs $ class_funcs cls)+          ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs cls)+      rawSelf = Right (CSTRawType, cls)+      raws =+        fmap (bimap (TCSTTemplate,) (CSTRawType,)) $ L.nub $ filter (/= Right cls) retDepClasses+      exts =+        let extclasses =+              filter (`isNotInSamePackageWith` Right cls) argDepClasses+            parents = map Right (class_parents cls)+         in fmap (bimap (TCSTTemplate,) (CSTInterface,)) $ L.nub (parents <> extclasses)+      inplaces =+        fmap (bimap (TCSTTemplate,) (CSTInterface,)) $+          L.nub $+            filter (`isInSamePackageButNotInheritedBy` Right cls) $ argDepClasses+   in rawSelf : (raws ++ exts ++ inplaces)+calculateDependency (Right (CSTCast, cls)) = [Right (CSTRawType, cls), Right (CSTInterface, cls)]+calculateDependency (Right (CSTImplementation, cls)) =+  let depsSelf =+        [ Right (CSTRawType, cls),+          Right (CSTFFI, cls),+          Right (CSTInterface, cls),+          Right (CSTCast, cls)+        ]+      dsFFI = fmap (bimap snd snd) $ mkDepFFI cls+      dsParents = L.nub $ map Right $ class_allparents cls+      dsNonParents = filter (not . (flip elem dsParents)) dsFFI +      deps =+        concatMap+          ( \case+              Left t -> [Left (TCSTTemplate, t)]+              Right c ->+                [ Right (CSTRawType, c),+                  Right (CSTCast, c),+                  Right (CSTInterface, c)+                ]+          )+          (dsNonParents <> dsParents)+   in depsSelf <> deps+ -- |-isNotInSamePackageWith-  :: Either TemplateClass Class-  -> Either TemplateClass Class-  -> Bool+isNotInSamePackageWith ::+  Either TemplateClass Class ->+  Either TemplateClass Class ->+  Bool isNotInSamePackageWith x y = (x /= y) && (getPkgName x /= getPkgName y)  -- x is in the sam-isInSamePackageButNotInheritedBy-  :: Either TemplateClass Class -- ^ y-  -> Either TemplateClass Class -- ^ x-  -> Bool+isInSamePackageButNotInheritedBy ::+  -- | y+  Either TemplateClass Class ->+  -- | x+  Either TemplateClass Class ->+  Bool isInSamePackageButNotInheritedBy x y =   x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y) --- TODO: Confirm the following answer--- NOTE: Q: why returnDependency is not considered?---       A: See explanation in mkModuleDepRaw-mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepHighNonSource y@(Right c) =-  let extclasses = filter (`isNotInSamePackageWith` y) $-                        concatMap (argumentDependency.extractClassDep) (class_funcs c)-                     ++ concatMap (argumentDependency.extractClassDep4TmplMemberFun) (class_tmpl_funcs c)-      parents = map Right (class_parents c)-  in  nub (parents <> extclasses)-mkModuleDepHighNonSource y@(Left t) =-  let fs = tclass_funcs t-      extclasses = filter (`isNotInSamePackageWith` y) $-                     concatMap (argumentDependency.extractClassDepForTmplFun) fs-  in  nub extclasses---- TODO: Confirm the following answer--- NOTE: Q: why returnDependency is not considered?---       A: See explanation in mkModuleDepRaw-mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepHighSource y@(Right c) =-  nub $-    filter (`isInSamePackageButNotInheritedBy` y) $-         concatMap (argumentDependency . extractClassDep) (class_funcs c)-      ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)-mkModuleDepHighSource y@(Left t) =-  let fs = tclass_funcs t-  in nub $-       filter (`isInSamePackageButNotInheritedBy` y) $-         concatMap (argumentDependency . extractClassDepForTmplFun) fs- -- | mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class] mkModuleDepCpp y@(Right c) =   let fs = class_funcs c       vs = class_vars c       tmfs = class_tmpl_funcs c-  in  nub . filter (/= y)  $-           concatMap (returnDependency.extractClassDep) fs-        <> concatMap (argumentDependency.extractClassDep) fs-        <> concatMap (classFromArg . unVariable) vs-        <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs-        <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs-        <> getparents y+   in L.nub . filter (/= y) $+        concatMap (returnDependency . extractClassDep) fs+          <> concatMap (argumentDependency . extractClassDep) fs+          <> concatMap (classFromArg . unVariable) vs+          <> concatMap (returnDependency . extractClassDep4TmplMemberFun) tmfs+          <> concatMap (argumentDependency . extractClassDep4TmplMemberFun) tmfs+          <> getparents y mkModuleDepCpp y@(Left t) =   let fs = tclass_funcs t-  in  nub . filter (/= y)  $-           concatMap (returnDependency.extractClassDepForTmplFun) fs-        <> concatMap (argumentDependency.extractClassDepForTmplFun) fs-        <> getparents y---- |-mkModuleDepFFI1 :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepFFI1 (Right c) = let fs = class_funcs c-                                vs = class_vars c-                                tmfs = class_tmpl_funcs c-                            in    concatMap (returnDependency.extractClassDep) fs-                               <> concatMap (argumentDependency.extractClassDep) fs-                               <> concatMap (classFromArg . unVariable) vs-                               <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs-                               <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs-mkModuleDepFFI1 (Left t)  = let fs = tclass_funcs t-                            in    concatMap (returnDependency.extractClassDepForTmplFun) fs-                               <> concatMap (argumentDependency.extractClassDepForTmplFun) fs+   in L.nub . filter (/= y) $+        concatMap (returnDependency . extractClassDepForTmplFun) fs+          <> concatMap (argumentDependency . extractClassDepForTmplFun) fs+          <> getparents y --- |-mkModuleDepFFI :: Either TemplateClass Class -> [Either TemplateClass Class]-mkModuleDepFFI y@(Right c) =-  let ps = map Right (class_allparents c)-      alldeps' = (concatMap mkModuleDepFFI1 ps) <> mkModuleDepFFI1 y-  in nub (filter (/= y) alldeps')-mkModuleDepFFI (Left _) = []+-- | Find module-level dependency per each toplevel function/template function.+mkTopLevelDep :: TopLevel -> [UClassSubmodule]+mkTopLevelDep (TLOrdinary f) =+  let dep4func = extractClassDepForTLOrdinary f+      allDeps = returnDependency dep4func ++ argumentDependency dep4func+      mkTags (Left tcl) = [Left (TCSTTemplate, tcl)]+      mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface]+   in concatMap mkTags allDeps+mkTopLevelDep (TLTemplate f) =+  let dep4func = extractClassDepForTLTemplate f+      allDeps = returnDependency dep4func ++ argumentDependency dep4func+      mkTags (Left tcl) = [Left (TCSTTemplate, tcl)]+      mkTags (Right cls) = fmap (Right . (,cls)) [CSTRawType, CSTCast, CSTInterface]+   in concatMap mkTags allDeps  -- |-mkClassModule :: (ModuleUnit -> ModuleUnitImports)-              -> [(String,[String])]-              -> Class-              -> ClassModule+mkClassModule ::+  (ModuleUnit -> ModuleUnitImports) ->+  [(String, [String])] ->+  Class ->+  ClassModule mkClassModule getImports extra c =-    ClassModule {-      cmModule = getClassModuleBase c-    , cmCIH = mkCIH getImports c-    , cmImportedModulesHighNonSource = highs_nonsource-    , cmImportedModulesRaw =raws-    , cmImportedModulesHighSource = highs_source-    , cmImportedModulesForFFI = ffis-    , cmExtraImport = extraimports+  ClassModule+    { cmModule = getClassModuleBase c,+      cmCIH = mkCIH getImports c,+      cmImportedSubmodulesForInterface = calculateDependency $ Right (CSTInterface, c),+      cmImportedSubmodulesForFFI = calculateDependency $ Right (CSTFFI, c),+      cmImportedSubmodulesForCast = calculateDependency $ Right (CSTCast, c),+      cmImportedSubmodulesForImplementation = calculateDependency $ Right (CSTImplementation, c),+      cmExtraImport = fromMaybe [] (lookup (class_name c) extra)     }-  where highs_nonsource = mkModuleDepHighNonSource (Right c)-        raws            = mkModuleDepRaw (Right c)-        highs_source    = mkModuleDepHighSource (Right c)-        ffis            = mkModuleDepFFI (Right c)-        extraimports = fromMaybe [] (lookup (class_name c) extra)  -- | findModuleUnitImports :: ModuleUnitMap -> ModuleUnit -> ModuleUnitImports@@ -314,121 +376,116 @@  -- | mkTCM ::-     TemplateClassImportHeader-  -> TemplateClassModule+  TemplateClassImportHeader ->+  TemplateClassModule mkTCM tcih =   let t = tcihTClass tcih-  in TCM (getTClassModuleBase t) tcih+   in TCM (getTClassModuleBase t) tcih  -- |-mkPackageConfig-  :: (CabalName, ModuleUnit -> ModuleUnitImports) -- ^ (package name,getImports)-  -> ([Class],[TopLevel],[TemplateClassImportHeader],[(String,[String])])-  -> [AddCInc]-  -> [AddCSrc]-  -> PackageConfig-mkPackageConfig (pkgname,getImports) (cs,fs,ts,extra) acincs acsrcs =+mkPackageConfig ::+  -- | (package name,getImports)+  (CabalName, ModuleUnit -> ModuleUnitImports) ->+  ([Class], [TopLevel], [TemplateClassImportHeader], [(String, [String])]) ->+  [AddCInc] ->+  [AddCSrc] ->+  PackageConfig+mkPackageConfig (pkgname, getImports) (cs, fs, ts, extra) acincs acsrcs =   let ms = map (mkClassModule getImports extra) cs       cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)-      cihs = nubBy cmpfunc (map cmCIH ms)+      cihs = L.nubBy cmpfunc (map cmCIH ms)       --       tih = mkTIH pkgname getImports cihs fs       tcms = map mkTCM ts       tcihs = map tcmTCIH tcms-  in PkgConfig {-       pcfg_classModules = ms-     , pcfg_classImportHeaders = cihs-     , pcfg_topLevelImportHeader = tih-     , pcfg_templateClassModules = tcms-     , pcfg_templateClassImportHeaders = tcihs-     , pcfg_additional_c_incs = acincs-     , pcfg_additional_c_srcs = acsrcs-     }---- TODO: change [String] to Set String-mkHSBOOTCandidateList :: [ClassModule] -> [String]-mkHSBOOTCandidateList ms =-  let-    -- get only class dependencies, not template classes.-    cs = rights (concatMap cmImportedModulesHighSource ms)-  in-    nub (map getClassModuleBase cs)+   in PkgConfig+        { pcfg_classModules = ms,+          pcfg_classImportHeaders = cihs,+          pcfg_topLevelImportHeader = tih,+          pcfg_templateClassModules = tcms,+          pcfg_templateClassImportHeaders = tcihs,+          pcfg_additional_c_incs = acincs,+          pcfg_additional_c_srcs = acsrcs+        }  -- |-mkPkgHeaderFileName ::Class -> HeaderName+mkPkgHeaderFileName :: Class -> HeaderName mkPkgHeaderFileName c =-    HdrName (   (cabal_cheaderprefix.class_cabal) c-            <>  fst (hsClassName c)-            <.> "h"-            )+  HdrName+    ( (cabal_cheaderprefix . class_cabal) c+        <> fst (hsClassName c)+        <.> "h"+    )  -- |-mkPkgCppFileName ::Class -> String+mkPkgCppFileName :: Class -> String mkPkgCppFileName c =-        (cabal_cheaderprefix.class_cabal) c-    <>  fst (hsClassName c)+  (cabal_cheaderprefix . class_cabal) c+    <> fst (hsClassName c)     <.> "cpp"  -- | mkPkgIncludeHeadersInH :: Class -> [HeaderName] mkPkgIncludeHeadersInH c =-    let pkgname = (cabal_pkgname . class_cabal) c-        extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c-        extheaders = nub . map ((<>"Type.h") . unCabalName . getPkgName) $ extclasses-    in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders+  let pkgname = (cabal_pkgname . class_cabal) c+      extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c+      extheaders = L.nub . map ((<> "Type.h") . unCabalName . getPkgName) $ extclasses+   in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders  -- | mkPkgIncludeHeadersInCPP :: Class -> [HeaderName] mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right  -- |-mkCIH :: (ModuleUnit -> ModuleUnitImports)  -- ^ (mk namespace and include headers)-      -> Class-      -> ClassImportHeader+mkCIH ::+  -- | (mk namespace and include headers)+  (ModuleUnit -> ModuleUnitImports) ->+  Class ->+  ClassImportHeader mkCIH getImports c =-  ClassImportHeader {-    cihClass                    = c-  , cihSelfHeader               = mkPkgHeaderFileName c-  , cihNamespace                = (muimports_namespaces . getImports . MU_Class . class_name) c-  , cihSelfCpp                  = mkPkgCppFileName c-  , cihImportedClasses          = mkModuleDepCpp (Right c)-  , cihIncludedHPkgHeadersInH   = mkPkgIncludeHeadersInH c-  , cihIncludedHPkgHeadersInCPP = mkPkgIncludeHeadersInCPP c-  , cihIncludedCPkgHeaders      = (muimports_headers . getImports . MU_Class . class_name) c-  }+  ClassImportHeader+    { cihClass = c,+      cihSelfHeader = mkPkgHeaderFileName c,+      cihNamespace = (muimports_namespaces . getImports . MU_Class . class_name) c,+      cihSelfCpp = mkPkgCppFileName c,+      cihImportedClasses = mkModuleDepCpp (Right c),+      cihIncludedHPkgHeadersInH = mkPkgIncludeHeadersInH c,+      cihIncludedHPkgHeadersInCPP = mkPkgIncludeHeadersInCPP c,+      cihIncludedCPkgHeaders = (muimports_headers . getImports . MU_Class . class_name) c+    }  -- | for top-level-mkTIH-  :: CabalName-  -> (ModuleUnit -> ModuleUnitImports)-  -> [ClassImportHeader]-  -> [TopLevel]-  -> TopLevelImportHeader+mkTIH ::+  CabalName ->+  (ModuleUnit -> ModuleUnitImports) ->+  [ClassImportHeader] ->+  [TopLevel] ->+  TopLevelImportHeader mkTIH pkgname getImports cihs fs =-  let tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevel) fs-      tl_cs2 = concatMap (returnDependency . extractClassDepForTopLevel) fs-      tl_cs = nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2)+  let ofs = filterTLOrdinary fs+      tl_cs1 = concatMap (argumentDependency . extractClassDepForTLOrdinary) ofs+      tl_cs2 = concatMap (returnDependency . extractClassDepForTLOrdinary) ofs+      tl_cs = L.nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2)       -- NOTE: Select only class dependencies in the current package.       -- TODO: This is clearly not a good impl. we need to look into this again       --       after reconsidering multi-package generation.       tl_cihs = catMaybes (foldr fn [] tl_cs)-         where-           fn c ys =-             let y = find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs-             in y:ys+        where+          fn c ys =+            let y = L.find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs+             in y : ys       -- NOTE: The remaining class dependencies outside the current package       extclasses = filter ((/= pkgname) . getPkgName) tl_cs-      extheaders = map HdrName $-                     nub $-                       map ((<>"Type.h") . unCabalName . getPkgName)  extclasses--  in-     TopLevelImportHeader {-       tihHeaderFileName = unCabalName pkgname <> "TopLevel"-     , tihClassDep = tl_cihs-     , tihExtraClassDep = extclasses-     , tihFuncs = fs-     , tihNamespaces        = muimports_namespaces (getImports MU_TopLevel)-     , tihExtraHeadersInH   = extheaders-     , tihExtraHeadersInCPP = muimports_headers (getImports MU_TopLevel)-     }+      extheaders =+        map HdrName $+          L.nub $+            map ((<> "Type.h") . unCabalName . getPkgName) extclasses+   in TopLevelImportHeader+        { tihHeaderFileName = unCabalName pkgname <> "TopLevel",+          tihClassDep = tl_cihs,+          tihExtraClassDep = extclasses,+          tihFuncs = fs,+          tihNamespaces = muimports_namespaces (getImports MU_TopLevel),+          tihExtraHeadersInH = extheaders,+          tihExtraHeadersInCPP = muimports_headers (getImports MU_TopLevel)+        }