packages feed

fficxx 0.2.1 → 0.3

raw patch · 38 files changed

+1862/−2099 lines, 38 filesdep +haskell-src-extsdep +templatedep +textdep −HStringTemplatedep ~errors

Dependencies added: haskell-src-exts, template, text

Dependencies removed: HStringTemplate

Dependency ranges changed: errors

Files

fficxx.cabal view
@@ -1,20 +1,15 @@-Name:		fficxx-Version:	0.2.1-Synopsis:	automatic C++ binding generation-Description: 	automatic C++ binding generation+Name:           fficxx+Version:        0.3+Synopsis:       automatic C++ binding generation+Description:    automatic C++ binding generation License:        BSD3-License-file:	LICENSE-Author:		Ian-Woo Kim-Maintainer: 	Ian-Woo Kim <ianwookim@gmail.com>-Build-Type: 	Simple+License-file:   LICENSE+Author:         Ian-Woo Kim+Maintainer:     Ian-Woo Kim <ianwookim@gmail.com>+Build-Type:     Simple Category:       FFI Tools Cabal-Version:  >= 1.8-Data-files: template/*.h.st-            template/*.hs.st-            template/*.hsc.st-            template/*.hs-boot.st-            template/*.cpp.st-            template/Pkg.cabal.st+Data-files:              sample/cxxlib/include/*.h             sample/cxxlib/src/*.cpp             sample/cxxlib/Makefile@@ -29,33 +24,33 @@  Library   hs-source-dirs: lib-  ghc-options: 	-Wall -funbox-strict-fields -fno-warn-unused-do-bind+  ghc-options:  -Wall -funbox-strict-fields -fno-warn-unused-do-bind   ghc-prof-options: -caf-all -auto-all   Build-Depends: base == 4.*,-                 data-default,-                 mtl>2,+                 Cabal,+                 bytestring,                  containers,-                 filepath>1,+                 data-default,                  directory,-                 HStringTemplate,-                 split,-                 process,-                 transformers >= 0.3,-                 template-haskell,+                 either,+                 errors,+                 filepath>1,                  hashable,-                 unordered-containers,+                 haskell-src-exts,                  lens > 3,-                 either,-                 errors < 2.0,-                 bytestring,+                 mtl>2,+                 process,                  pureMD5,-                 Cabal+                 split,+                 transformers >= 0.3,+                 template,+                 template-haskell,+                 text,+                 unordered-containers+                     Exposed-Modules:                    FFICXX.Generate.Builder-                   FFICXX.Generate.Type.Class-                   FFICXX.Generate.Type.Module-                   FFICXX.Generate.Type.PackageInterface                    FFICXX.Generate.Config                    FFICXX.Generate.Code.MethodDef                    FFICXX.Generate.Code.Cpp@@ -63,12 +58,13 @@                    FFICXX.Generate.Code.HsFFI                    FFICXX.Generate.Code.Cabal                    FFICXX.Generate.Code.Dependency-                   FFICXX.Generate.Generator.Driver-                   FFICXX.Generate.Generator.ContentMaker-                   FFICXX.Generate.Util+                   FFICXX.Generate.ContentMaker                    FFICXX.Generate.QQ.Verbatim+                   FFICXX.Generate.Util+                   FFICXX.Generate.Util.HaskellSrcExts                    FFICXX.Generate.Type.Annotate-                   FFICXX.Paths_fficxx-  Other-Modules:-                   Paths_fficxx+                   FFICXX.Generate.Type.Class+                   FFICXX.Generate.Type.Module+                   FFICXX.Generate.Type.PackageInterface+
lib/FFICXX/Generate/Builder.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Builder--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,97 +15,40 @@  module FFICXX.Generate.Builder where -import           Data.Char (toUpper)-import qualified Data.HashMap.Strict as HM-import           Data.List (intercalate)-import           Data.Monoid (mempty)-import           System.FilePath ((</>), (<.>))-import           System.Directory (getCurrentDirectory)-import           System.Process (readProcess)-import           Text.StringTemplate hiding (render)+import           Control.Monad                           ( forM_, void, when )+import qualified Data.ByteString.Lazy.Char8        as L+import           Data.Char                               ( toUpper )+import           Data.Digest.Pure.MD5                    ( md5 )+import qualified Data.HashMap.Strict               as HM+import           Data.Monoid                             ( (<>), mempty )+import           Language.Haskell.Exts.Pretty            ( prettyPrint )+import           System.FilePath                         ( (</>), (<.>), splitExtension )+import           System.Directory                        ( copyFile, doesDirectoryExist+                                                         , doesFileExist, getCurrentDirectory )+import           System.IO                               ( hPutStrLn, withFile, IOMode(..) )+import           System.Process                          ( readProcess, system ) -- import           FFICXX.Generate.Code.Cabal-import           FFICXX.Generate.Code.Cpp import           FFICXX.Generate.Code.Dependency import           FFICXX.Generate.Config-import           FFICXX.Generate.Code.Cpp-import           FFICXX.Generate.Code.Dependency-import           FFICXX.Generate.Config-import           FFICXX.Generate.Generator.ContentMaker-import           FFICXX.Generate.Generator.Driver-import           FFICXX.Generate.Type.Annotate-import           FFICXX.Generate.Type.Class ( Cabal(..)-                                            , CabalAttr(..)-                                            , Class-                                            , ClassModule-                                            , Namespace(NS)-                                            , TopLevelFunction-                                            , TopLevelImportHeader-                                            )+import           FFICXX.Generate.ContentMaker+import           FFICXX.Generate.Type.Class +import           FFICXX.Generate.Type.Module   import           FFICXX.Generate.Type.PackageInterface import           FFICXX.Generate.Util ---import qualified FFICXX.Paths_fficxx as F --- |-cabalTemplate :: String-cabalTemplate = "Pkg.cabal"----- |-mkCabalFile :: FFICXXConfig-            -> STGroup String-            -> (Cabal, CabalAttr)-            -> String-            -> (TopLevelImportHeader,[ClassModule])-            -> [String] -- ^ extra libs-            -> FilePath-            -> IO ()-mkCabalFile config-            templates-            (cabal, cabalattr)-            summarymodule-            (tih,classmodules)-            extralibs-            cabalfile-            = do-  cpath <- getCurrentDirectory--  let str = renderTemplateGroup-              templates-              ( [ ("licenseField", "license: " ++ license)-                  | Just license <- [cabalattr_license cabalattr] ] ++-                [ ("licenseFileField", "license-file: " ++ licensefile)-                  | Just licensefile <- [cabalattr_licensefile cabalattr] ] ++-                [ ("pkgname", cabal_pkgname cabal)-                , ("version",  "0.0")-                , ("buildtype", "Simple")-                , ("deps", "")-                , ("csrcFiles", genCsrcFiles (tih,classmodules))-                , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) classmodules)-                , ("cppFiles", genCppFiles (tih,classmodules))-                , ("exposedModules", genExposedModules summarymodule classmodules)-                , ("otherModules", genOtherModules classmodules)-                , ("extralibdirs", intercalate ", " $ cabalattr_extralibdirs cabalattr)-                , ("extraincludedirs", intercalate ", " $ cabalattr_extraincludedirs cabalattr)-                , ("extraLibraries", concatMap (", " ++) extralibs)-                , ("cabalIndentation", cabalIndentation)-                ]-              )-              cabalTemplate-  writeFile cabalfile str-- macrofy :: String -> String macrofy = map ((\x->if x=='-' then '_' else x) . toUpper)  simpleBuilder :: String -> [(String,([Namespace],[HeaderName]))]-              -> (Cabal, CabalAttr, [Class], [TopLevelFunction])+              -> (Cabal, CabalAttr, [Class], [TopLevelFunction], [(TemplateClass,HeaderName)])               -> [String] -- ^ extra libs+              -> [(String,[String])] -- ^ extra module               ->  IO ()-simpleBuilder summarymodule m (cabal, cabalattr, myclasses, toplevelfunctions) extralibs = do+simpleBuilder summarymodule lst (cabal, cabalattr, classes, toplevelfunctions, templates) extralibs extramods = do   let pkgname = cabal_pkgname cabal-  putStrLn ("generating " ++ pkgname)+  putStrLn ("generating " <> pkgname)   cwd <- getCurrentDirectory   let cfg =  FFICXXConfig { fficxxconfig_scriptBaseDir = cwd                           , fficxxconfig_workingDir = cwd </> "working"@@ -113,15 +57,10 @@       workingDir = fficxxconfig_workingDir cfg       installDir = fficxxconfig_installBaseDir cfg -      (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH-                          (pkgname, mkClassNSHeaderFromMap (HM.fromList m))-                          (myclasses, toplevelfunctions)+      pkgconfig@(PkgConfig mods cihs tih tcms _tcihs) =+        mkPackageConfig (pkgname, mkClassNSHeaderFromMap (HM.fromList lst)) (classes, toplevelfunctions,templates,extramods)       hsbootlst = mkHSBOOTCandidateList mods-      cglobal = mkGlobal myclasses-      -- summarymodule = -- pkgname -- "Snappy"-      cabalFileName = pkgname <.> "cabal" -- "Snappy.cabal"-  templateDir <- F.getDataDir >>= return . (</> "template")-  (templates :: STGroup String) <- directoryGroup templateDir+      cabalFileName = pkgname <.> "cabal"    --   notExistThenCreate workingDir   notExistThenCreate installDir@@ -129,55 +68,149 @@   notExistThenCreate (installDir </> "csrc")   --   putStrLn "cabal file generation"-  mkCabalFile cfg templates (cabal, cabalattr) summarymodule (tih,mods) extralibs (workingDir </> cabalFileName)+  buildCabalFile (cabal,cabalattr) summarymodule pkgconfig extralibs (workingDir</>cabalFileName)   --   putStrLn "header file generation"-  let typmacro = TypMcro ("__"  ++ macrofy (cabal_pkgname cabal) ++ "__")  {- "__SNAPPY__" -}-  writeTypeDeclHeaders templates workingDir typmacro pkgname cihs-  mapM_ (writeDeclHeaders templates workingDir typmacro pkgname) cihs-  writeTopLevelFunctionHeaders templates workingDir typmacro pkgname tih+  let typmacro = TypMcro ("__"  <> macrofy (cabal_pkgname cabal) <> "__")+      gen :: FilePath -> String -> IO ()+      gen file str =+        let path = workingDir </> file in withFile path WriteMode (flip hPutStrLn str)+++  gen (pkgname <> "Type.h") (buildTypeDeclHeader typmacro (map cihClass cihs))+  mapM_ (\hdr -> gen (unHdrName (cihSelfHeader hdr)) (buildDeclHeader typmacro pkgname hdr)) cihs+  gen (tihHeaderFileName tih <.> "h") (buildTopLevelFunctionHeader typmacro pkgname tih)+  forM_ tcms $ \m ->+    let tcihs = tcmTCIH m+    in forM_ tcihs $ \tcih ->+         let t = tcihTClass tcih+             hdr = unHdrName (tcihSelfHeader tcih)+         in gen hdr (buildTemplateHeader typmacro t)   --   putStrLn "cpp file generation"-  mapM_ (writeCppDef templates workingDir) cihs-  writeTopLevelFunctionCppDef templates workingDir typmacro pkgname tih+  mapM_ (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) cihs+  gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelFunctionCppDef tih)   --   putStrLn "RawType.hs file generation"-  mapM_ (writeRawTypeHs templates workingDir) mods+  mapM_ (\m -> gen (cmModule m <.> "RawType" <.> "hs") (prettyPrint (buildRawTypeHs m))) mods   --   putStrLn "FFI.hsc file generation"-  mapM_ (writeFFIHsc templates workingDir) mods+  mapM_ (\m -> gen (cmModule m <.> "FFI" <.> "hsc") (prettyPrint (buildFFIHsc m))) mods   --   putStrLn "Interface.hs file generation"-  mapM_ (writeInterfaceHs mempty templates workingDir) mods+  mapM_ (\m -> gen (cmModule m <.> "Interface" <.> "hs") (prettyPrint (buildInterfaceHs mempty m))) mods   --   putStrLn "Cast.hs file generation"-  mapM_ (writeCastHs templates workingDir) mods+  mapM_ (\m -> gen (cmModule m <.> "Cast" <.> "hs") (prettyPrint (buildCastHs m))) mods   --   putStrLn "Implementation.hs file generation"-  mapM_ (writeImplementationHs mempty templates workingDir) mods+  mapM_ (\m -> gen (cmModule m <.> "Implementation" <.> "hs") (prettyPrint (buildImplementationHs mempty m))) mods   --+  putStrLn "Template.hs file generation"+  mapM_ (\m -> gen (tcmModule m <.> "Template" <.> "hs") (prettyPrint (buildTemplateHs m))) tcms +  -- +  putStrLn "TH.hs file generation"+  mapM_ (\m -> gen (tcmModule m <.> "TH" <.> "hs") (prettyPrint (buildTHHs m))) tcms +++  --    putStrLn "hs-boot file generation"-  mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst+  mapM_ (\m -> gen (m <.> "Interface" <.> "hs-boot") (prettyPrint (buildInterfaceHSBOOT m))) hsbootlst   --+++     putStrLn "module file generation"-  mapM_ (writeModuleHs templates workingDir) mods+  mapM_ (\m -> gen (cmModule m <.> "hs") (prettyPrint (buildModuleHs m))) mods   --   putStrLn "summary module generation generation"-  writePkgHs summarymodule templates workingDir mods tih+  gen (summarymodule <.> "hs") (buildPkgHs summarymodule mods tih)   --   putStrLn "copying"   touch (workingDir </> "LICENSE")   copyFileWithMD5Check (workingDir </> cabalFileName)  (installDir </> cabalFileName)   copyFileWithMD5Check (workingDir </> "LICENSE") (installDir </> "LICENSE")-  -- copyPredefined templateDir (srcDir ibase) pkgname -  copyCppFiles workingDir (csrcDir installDir) pkgname (tih,cihs)-  mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods+  copyCppFiles workingDir (csrcDir installDir) pkgname pkgconfig+  mapM_ (copyModule workingDir (srcDir installDir)) mods+  mapM_ (copyTemplateModule workingDir (srcDir installDir)) tcms  +  moduleFileCopy workingDir (srcDir installDir) $ summarymodule <.> "hs"   -- | some dirty hack. later, we will do it with more proper approcah.  touch :: FilePath -> IO ()-touch fp = do-    readProcess "touch" [fp] ""-    return ()+touch fp = void (readProcess "touch" [fp] "")+++notExistThenCreate :: FilePath -> IO () +notExistThenCreate dir = do +    b <- doesDirectoryExist dir+    if b then return () else system ("mkdir -p " <> dir) >> return ()+++copyFileWithMD5Check :: FilePath -> FilePath -> IO () +copyFileWithMD5Check src tgt = do+  b <- doesFileExist tgt +  if b +    then do +      srcmd5 <- md5 <$> L.readFile src  +      tgtmd5 <- md5 <$> L.readFile tgt +      if srcmd5 == tgtmd5 then return () else copyFile src tgt +    else copyFile src tgt  +++copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO ()+copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs) = do +  let thfile = cprefix <> "Type.h"+      tlhfile = tihHeaderFileName tih <.> "h"+      tlcppfile = tihHeaderFileName tih <.> "cpp"+  copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile) +  doesFileExist (wdir </> tlhfile) +    >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))+  doesFileExist (wdir </> tlcppfile) +    >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))+  forM_ cihs $ \header-> do +    let hfile = unHdrName (cihSelfHeader header)+        cppfile = cihSelfCpp header+    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) +    copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)++  forM_ tcihs $ \header-> do +    let hfile = unHdrName (tcihSelfHeader header)+    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) +++moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO ()+moduleFileCopy wdir ddir fname = do +  let (fnamebody,fnameext) = splitExtension fname+      (mdir,mfile) = moduleDirFile fnamebody+      origfpath = wdir </> fname+      (mfile',_mext') = splitExtension mfile+      newfpath = ddir </> mdir </> mfile' <> fnameext   +  b <- doesFileExist origfpath +  when b $ do +    notExistThenCreate (ddir </> mdir) +    copyFileWithMD5Check origfpath newfpath +++copyModule :: FilePath -> FilePath -> ClassModule -> IO ()+copyModule wdir ddir m = do +  let modbase = cmModule m ++  moduleFileCopy wdir ddir $ modbase <> ".hs"+  moduleFileCopy wdir ddir $ modbase <> ".RawType.hs"+  moduleFileCopy wdir ddir $ modbase <> ".FFI.hsc"+  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs"+  moduleFileCopy wdir ddir $ modbase <> ".Cast.hs"+  moduleFileCopy wdir ddir $ modbase <> ".Implementation.hs"+  moduleFileCopy wdir ddir $ modbase <> ".Interface.hs-boot"+  return ()++copyTemplateModule :: FilePath -> FilePath -> TemplateClassModule -> IO ()+copyTemplateModule wdir ddir m = do +  let modbase = tcmModule m +  moduleFileCopy wdir ddir $ modbase <> ".Template.hs"+  moduleFileCopy wdir ddir $ modbase <> ".TH.hs"+  return ()+
lib/FFICXX/Generate/Code/Cabal.hs view
@@ -1,7 +1,9 @@+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Code.Cabal--- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,25 +14,167 @@  module FFICXX.Generate.Code.Cabal where -import FFICXX.Generate.Type.Class +import           Data.List                   ( intercalate, nub )+import           Data.Monoid                 ( (<>) )+import           Data.Text                   ( Text )+import           System.FilePath             ( (<.>), (</>) )+--+import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.Module+import           FFICXX.Generate.Type.PackageInterface+import           FFICXX.Generate.Util + cabalIndentation :: String  cabalIndentation = replicate 23 ' '   +genIncludeFiles :: String        -- ^ package name +                -> ([ClassImportHeader],[TemplateClassImportHeader])+                -> String+genIncludeFiles pkgname (cih,tcih) =+  let indent = cabalIndentation +      selfheaders = map cihSelfHeader cih <> map tcihSelfHeader tcih+      -- selfheaders = nub selfheaders'+      includeFileStrs = map ((indent<>).unHdrName) selfheaders+  in  unlines ((indent<>pkgname<>"Type.h") : includeFileStrs)++genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> String+genCsrcFiles (tih,cmods) =+  let indent = cabalIndentation +      selfheaders' = do +        x <- cmods+        y <- cmCIH x+        return (cihSelfHeader y) +      selfheaders = nub selfheaders'+      selfcpp' = do +        x <- cmods+        y <- cmCIH x +        return (cihSelfCpp y)+      selfcpp = nub selfcpp' +      tlh = tihHeaderFileName tih <.> "h"+      tlcpp = tihHeaderFileName tih <.> "cpp"+      includeFileStrsWithCsrc = map (\x->indent<>"csrc"</> x) +                                 (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders))+      cppFilesWithCsrc = map (\x->indent<>"csrc"</>x) +                           (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)+      +  in  unlines (includeFileStrsWithCsrc <> cppFilesWithCsrc)++genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> String +genCppFiles (tih,cmods) = +  let indent = cabalIndentation +      selfcpp' = do +        x <- cmods+        y <- cmCIH x+        return (cihSelfCpp y) +      selfcpp = nub selfcpp'+      tlcpp = tihHeaderFileName tih <.> "cpp"+      cppFileStrs = map (\x->indent<> "csrc" </> x) +                      (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)+  in  unlines cppFileStrs +++ -- | generate exposed module list in cabal file -genExposedModules :: String -> [ClassModule] -> String-genExposedModules summarymod cmods = +genExposedModules :: String -> ([ClassModule],[TemplateClassModule]) -> String+genExposedModules summarymod (cmods,tmods) =      let indentspace = cabalIndentation-        summarystrs = indentspace ++ summarymod -        cmodstrs = map ((\x->indentspace++x).cmModule) cmods -        rawType = map ((\x->indentspace++x++".RawType").cmModule) cmods-        ffi = map ((\x->indentspace++x++".FFI").cmModule) cmods-        interface= map ((\x->indentspace++x++".Interface").cmModule) cmods-        cast = map ((\x->indentspace++x++".Cast").cmModule) cmods -        implementation = map ((\x->indentspace++x++".Implementation").cmModule) cmods-    in  unlines ([summarystrs]++cmodstrs++rawType++ffi++interface++cast++implementation)+        summarystrs = indentspace <> summarymod +        cmodstrs = map ((\x->indentspace<>x).cmModule) cmods +        rawType = map ((\x->indentspace<>x<>".RawType").cmModule) cmods+        ffi = map ((\x->indentspace<>x<>".FFI").cmModule) cmods+        interface= map ((\x->indentspace<>x<>".Interface").cmModule) cmods+        cast = map ((\x->indentspace<>x<>".Cast").cmModule) cmods +        implementation = map ((\x->indentspace<>x<>".Implementation").cmModule) cmods+        template = map ((\x->indentspace<>x<>".Template").tcmModule) tmods+        th = map ((\x->indentspace<>x<>".TH").tcmModule) tmods        +    in  unlines ([summarystrs]<>cmodstrs<>rawType<>ffi<>interface<>cast<>implementation<>template<>th)  -- | generate other modules in cabal file  genOtherModules :: [ClassModule] -> String  genOtherModules _cmods = "" +++-- |+cabalTemplate :: Text+cabalTemplate =+  "Name:                $pkgname\n\+  \Version:     $version\n\+  \Synopsis:    $synopsis\n\+  \Description:         $description\n\+  \Homepage:       $homepage\n\+  \$licenseField\n\+  \$licenseFileField\n\+  \Author:              $author\n\+  \Maintainer:  $maintainer\n\+  \Category:       $category\n\+  \Tested-with:    GHC >= 7.6\n\+  \Build-Type:  $buildtype\n\+  \cabal-version:  >=1.10\n\+  \Extra-source-files:\n\+  \$csrcFiles\n\+  \\n\+  \$sourcerepository\n\+  \\n\+  \Library\n\+  \  default-language: Haskell2010\n\+  \  hs-source-dirs: src\n\+  \  ghc-options:  -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports\n\+  \  ghc-prof-options: -caf-all -auto-all\n\+  \  cc-options: $ccOptions\n\+  \  Build-Depends:      base>4 && < 5, fficxx >= 0.3, fficxx-runtime >= 0.3, template-haskell$deps\n\+  \  Exposed-Modules:\n\+  \$exposedModules\n\+  \  Other-Modules:\n\+  \$otherModules\n\+  \  extra-lib-dirs: $extralibdirs\n\+  \  extra-libraries:    stdc++ $extraLibraries\n\+  \  Include-dirs:       csrc $extraincludedirs\n\+  \  Install-includes:\n\+  \$includeFiles\n\+  \  C-sources:\n\+  \$cppFiles\n"++-- |+buildCabalFile :: (Cabal, CabalAttr)+            -> String+            -> PackageConfig -- (TopLevelImportHeader,[ClassModule],[TemplateClassModule])+            -> [String] -- ^ extra libs+            -> FilePath+            -> IO ()+buildCabalFile (cabal, cabalattr) summarymodule pkgconfig extralibs cabalfile = do+  let tih = pcfg_topLevelImportHeader pkgconfig+      classmodules = pcfg_classModules pkgconfig+      cih = pcfg_classImportHeaders pkgconfig+      tmods = pcfg_templateClassModules pkgconfig+      tcih = pcfg_templateClassImportHeaders pkgconfig+      txt = subst cabalTemplate+              (context ([ ("licenseField", "license: " <> license)+                          | Just license <- [cabalattr_license cabalattr] ] <>+                        [ ("licenseFileField", "license-file: " <> licensefile)+                          | Just licensefile <- [cabalattr_licensefile cabalattr] ] <>+                        [ ("pkgname", cabal_pkgname cabal)+                        , ("version",  "0.0")+                        , ("buildtype", "Simple")+                        , ("synopsis", "")+                        , ("description", "")+                        , ("homepage","")+                        , ("author","")+                        , ("maintainer","")+                        , ("category","")+                        , ("sourcerepository","")+                        , ("ccOptions","-std=c++14")+                        , ("deps", "")+                        , ("csrcFiles", genCsrcFiles (tih,classmodules))+                        , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) (cih,tcih) )+                        , ("cppFiles", genCppFiles (tih,classmodules))+                        , ("exposedModules", genExposedModules summarymodule (classmodules,tmods))+                        , ("otherModules", genOtherModules classmodules)+                        , ("extralibdirs", intercalate ", " $ cabalattr_extralibdirs cabalattr)+                        , ("extraincludedirs", intercalate ", " $ cabalattr_extraincludedirs cabalattr)+                        , ("extraLibraries", concatMap (", " <>) extralibs)+                        , ("cabalIndentation", cabalIndentation)+                        ]))+  writeFile cabalfile txt+
lib/FFICXX/Generate/Code/Cpp.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Code.Cpp--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,17 +15,19 @@  module FFICXX.Generate.Code.Cpp where -import Data.Char -import Data.List-import System.FilePath--import FFICXX.Generate.Util-import FFICXX.Generate.Code.MethodDef-import FFICXX.Generate.Code.Cabal-import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.PackageInterface+import           Data.Char +import           Data.Monoid                           ( (<>) )+--+import           FFICXX.Generate.Util+import           FFICXX.Generate.Code.MethodDef+import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.Module+import           FFICXX.Generate.Type.PackageInterface+-- +-- -- Class Declaration and Definition+--  ---- ---- Declaration@@ -33,11 +36,11 @@ ---- "Class Type Declaration" Instances  genCppHeaderTmplType :: Class -> String -genCppHeaderTmplType c = let tmpl = "// Opaque type definition for $classname$ \n\-                                    \typedef struct $classname$_tag $classname$_t; \n\-                                    \typedef $classname$_t * $classname$_p; \n\-                                    \typedef $classname$_t const* const_$classname$_p; \n"-                      in  render tmpl [ ("classname", class_name c) ] +genCppHeaderTmplType c = let tmpl = "// Opaque type definition for $classname \n\+                                    \typedef struct ${classname}_tag ${classname}_t; \n\+                                    \typedef ${classname}_t * ${classname}_p; \n\+                                    \typedef ${classname}_t const* const_${classname}_p; \n"+                      in subst tmpl (context [ ("classname", class_name c) ])  genAllCppHeaderTmplType :: [Class] -> String genAllCppHeaderTmplType = intercalateWith connRet2 (genCppHeaderTmplType) @@ -46,11 +49,10 @@  genCppHeaderTmplVirtual :: Class -> String  genCppHeaderTmplVirtual aclass =  -  let tmpl = "#undef $classname$_DECL_VIRT\\\n#define $classname$_DECL_VIRT(Type) \\\\\\\n$funcdecl$" -      declBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) -                                 , ("funcdecl" , funcDeclStr ) ] +  let tmpl = "#undef ${classname}_DECL_VIRT \n#define ${classname}_DECL_VIRT(Type) \\\n${funcdecl}"       funcDeclStr = (funcsToDecls aclass) . virtualFuncs . class_funcs $ aclass-  in  declBodyStr +  in subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) +                         , ("funcdecl" , funcDeclStr                     ) ])         genAllCppHeaderTmplVirtual :: [Class] -> String  genAllCppHeaderTmplVirtual = intercalateWith connRet2 genCppHeaderTmplVirtual@@ -59,9 +61,9 @@  genCppHeaderTmplNonVirtual :: Class -> String genCppHeaderTmplNonVirtual c = -  let tmpl = "#undef $classname$_DECL_NONVIRT\\\n#define $classname$_DECL_NONVIRT(Type) \\\\\\\n$funcdecl$" -      declBodyStr = render tmpl [ ("classname", map toUpper (class_name c) ) -                                 , ("funcdecl" , funcDeclStr ) ] +  let tmpl = "#undef ${classname}_DECL_NONVIRT \n#define ${classname}_DECL_NONVIRT(Type) \\\n$funcdecl" +      declBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name c))+                                        , ("funcdecl" , funcDeclStr               ) ])       funcDeclStr = (funcsToDecls c) . filter (not.isVirtualFunc)                                       . class_funcs $ c   in  declBodyStr @@ -74,12 +76,12 @@ genCppHeaderInstVirtual :: (Class,Class) -> String  genCppHeaderInstVirtual (p,c) =    let strc = map toUpper (class_name p) -  in  strc++"_DECL_VIRT(" ++ class_name c ++ ");\n"+  in  strc<>"_DECL_VIRT(" <> class_name c <> ");\n"  genCppHeaderInstNonVirtual :: Class -> String  genCppHeaderInstNonVirtual c =    let strx = map toUpper (class_name c) -  in  strx++"_DECL_NONVIRT(" ++ class_name c ++ ");\n" +  in  strx<>"_DECL_NONVIRT(" <> class_name c <> ");\n"   genAllCppHeaderInstNonVirtual :: [Class] -> String  genAllCppHeaderInstNonVirtual = @@ -94,9 +96,9 @@  genCppDefTmplVirtual :: Class -> String  genCppDefTmplVirtual aclass =  -  let tmpl = "#undef $classname$_DEF_VIRT\\\n#define $classname$_DEF_VIRT(Type)\\\\\\\n$funcdef$" -      defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) -                               , ("funcdef" , funcDefStr ) ] +  let tmpl = "#undef ${classname}_DEF_VIRT\n#define ${classname}_DEF_VIRT(Type)\\\n$funcdef" +      defBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) +                                       , ("funcdef"  , funcDefStr                      ) ])        funcDefStr = (funcsToDefs aclass) . virtualFuncs . class_funcs $ aclass   in  defBodyStr        @@ -107,9 +109,9 @@  genCppDefTmplNonVirtual :: Class -> String  genCppDefTmplNonVirtual aclass =  -  let tmpl = "#undef $classname$_DEF_NONVIRT\\\n#define $classname$_DEF_NONVIRT(Type)\\\\\\\n$funcdef$" -      defBodyStr = render tmpl [ ("classname", map toUpper (class_name aclass) ) -                               , ("funcdef" , funcDefStr ) ] +  let tmpl = "#undef ${classname}_DEF_NONVIRT\n#define ${classname}_DEF_NONVIRT(Type)\\\n$funcdef" +      defBodyStr = subst tmpl (context [ ("classname", map toUpper (class_name aclass) ) +                                       , ("funcdef"  , funcDefStr                      ) ])        funcDefStr = (funcsToDefs aclass) . filter (not.isVirtualFunc)                                          . class_funcs $ aclass   in  defBodyStr @@ -122,144 +124,112 @@ genCppDefInstVirtual :: (Class,Class) -> String  genCppDefInstVirtual (p,c) =    let strc = map toUpper (class_name p) -  in  strc++"_DEF_VIRT(" ++ class_name c ++ ")\n"+  in  strc<>"_DEF_VIRT(" <> class_name c <> ")\n"  genCppDefInstNonVirtual :: Class -> String genCppDefInstNonVirtual c = -  let tmpl = "$capitalclassname$_DEF_NONVIRT($classname$)" -  in  render tmpl [ ("capitalclassname", toUppers (class_name c))-                  , ("classname", class_name c) ] +  subst "${capitalclassname}_DEF_NONVIRT(${classname})"+    (context [ ("capitalclassname", toUppers (class_name c))+             , ("classname"       , class_name c           ) ])   genAllCppDefInstNonVirtual :: [Class] -> String -genAllCppDefInstNonVirtual = -  intercalateWith connRet genCppDefInstNonVirtual--------+genAllCppDefInstNonVirtual = intercalateWith connRet genCppDefInstNonVirtual  -----------------  genAllCppHeaderInclude :: ClassImportHeader -> String  genAllCppHeaderInclude header = -    intercalateWith connRet (\x->"#include \""++x++"\"") $+    intercalateWith connRet (\x->"#include \""<>x<>"\"") $       map unHdrName (cihIncludedHPkgHeadersInCPP header-                     ++ cihIncludedCPkgHeaders header)---genModuleIncludeHeader :: [ClassImportHeader] -> String -genModuleIncludeHeader headers =-  let strlst = map ((\x->"#include \""++x++"\"") . unHdrName . cihSelfHeader) headers -  in  intercalate "\n" strlst +                     <> cihIncludedCPkgHeaders header)  ---- -genIncludeFiles :: String        -- ^ package name -                -> [ClassModule] -                -> String-genIncludeFiles pkgname cmods =-  let indent = cabalIndentation -      selfheaders' = do -        x <- cmods-        y <- cmCIH x-        return (cihSelfHeader y) -      selfheaders = nub selfheaders'-      includeFileStrs = map ((indent++).unHdrName) selfheaders-  in  unlines ((indent++pkgname++"Type.h") : includeFileStrs) -genCsrcFiles :: (TopLevelImportHeader,[ClassModule]) -> String-genCsrcFiles (tih,cmods) =-  let indent = cabalIndentation -      selfheaders' = do -        x <- cmods-        y <- cmCIH x-        return (cihSelfHeader y) -      selfheaders = nub selfheaders'-      selfcpp' = do -        x <- cmods-        y <- cmCIH x -        return (cihSelfCpp y)-      selfcpp = nub selfcpp' -      tlh = tihHeaderFileName tih <.> "h"-      tlcpp = tihHeaderFileName tih <.> "cpp"-      includeFileStrsWithCsrc = map (\x->indent++"csrc"</> x) -                                 (if (null.tihFuncs) tih then map unHdrName selfheaders else tlh:(map unHdrName selfheaders))-      cppFilesWithCsrc = map (\x->indent++"csrc"</>x) -                           (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)-      -  in  unlines (includeFileStrsWithCsrc ++ cppFilesWithCsrc) -genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> String -genCppFiles (tih,cmods) = -  let indent = cabalIndentation -      selfcpp' = do -        x <- cmods-        y <- cmCIH x-        return (cihSelfCpp y) -      selfcpp = nub selfcpp'-      tlcpp = tihHeaderFileName tih <.> "cpp"-      cppFileStrs = map (\x->indent++ "csrc" </> x) -                      (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)-  in  unlines cppFileStrs --- ------------------------- -- TOP LEVEL FUNCTIONS -- -------------------------  genTopLevelFuncCppHeader :: TopLevelFunction -> String  genTopLevelFuncCppHeader TopLevelFunction {..} = -    let tmpl = "$returntype$ $funcname$ ( $args$ );" -    in  render tmpl [ ("returntype", rettypeToString toplevelfunc_ret)  -                    , ("funcname", "TopLevel_" -                                   ++ maybe toplevelfunc_name id toplevelfunc_alias)-                    , ("args", argsToStringNoSelf toplevelfunc_args) ] +  subst "$returntype $funcname ( $args );" +    (context [ ("returntype", rettypeToString toplevelfunc_ret                )  +             , ("funcname"  , "TopLevel_" +                              <> maybe toplevelfunc_name id toplevelfunc_alias)+             , ("args"      , argsToStringNoSelf toplevelfunc_args            ) ]) genTopLevelFuncCppHeader TopLevelVariable {..} = -    let tmpl = "$returntype$ $funcname$ ( );" -    in  render tmpl [ ("returntype", rettypeToString toplevelvar_ret)  -                    , ("funcname", "TopLevel_" -                                   ++ maybe toplevelvar_name id toplevelvar_alias)-                    ] +  subst "$returntype $funcname ( );"+    (context [ ("returntype", rettypeToString toplevelvar_ret                )  +             , ("funcname"  , "TopLevel_" +                               <> maybe toplevelvar_name id toplevelvar_alias) ])   genTopLevelFuncCppDefinition :: TopLevelFunction -> String  genTopLevelFuncCppDefinition TopLevelFunction {..} =  -    let tmpl = "$returntype$ $funcname$ ( $args$ ) { \\\n  $funcbody$\\\n}" -        callstr = toplevelfunc_name ++ "("-                  ++ argsToCallString toplevelfunc_args   -                  ++ ")"-        returnstr = case toplevelfunc_ret of          -          Void -> callstr ++ ";"-          SelfType -> "return to_nonconst<Type ## _t, Type>((Type *)" ++ callstr ++ ") ;"-          (CT (CRef _) _) -> "return ((*)"++callstr++");"-          (CT _ctyp _isconst) -> "return "++callstr++";" -          (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str-                                    ++">(("++str++"*)"++callstr++");" -            where str = class_name c' -          (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" -        funcDefStr = returnstr -    in  render tmpl [ ("returntype", rettypeToString toplevelfunc_ret)  -                    , ("funcname", "TopLevel_" -                                   ++ maybe toplevelfunc_name id toplevelfunc_alias)-                    , ("args", argsToStringNoSelf toplevelfunc_args) -                    , ("funcbody", funcDefStr )-                    ] +  let tmpl = "$returntype $funcname ( $args ) { \n  $funcbody\n}" +      callstr = toplevelfunc_name <> "("+                <> argsToCallString toplevelfunc_args   +                <> ")"+      funcDefStr = returnCpp False (toplevelfunc_ret) callstr+  in subst tmpl (context [ ("returntype", rettypeToString toplevelfunc_ret                )  +                         , ("funcname"  , "TopLevel_" +                                          <> maybe toplevelfunc_name id toplevelfunc_alias)+                         , ("args"      , argsToStringNoSelf toplevelfunc_args            ) +                         , ("funcbody"  , funcDefStr                                      ) ]) genTopLevelFuncCppDefinition TopLevelVariable {..} =  -    let tmpl = "$returntype$ $funcname$ ( ) { \\\n  $funcbody$\\\n}" -        callstr = toplevelvar_name-        returnstr = case toplevelvar_ret of          -          Void -> callstr ++ ";"-          SelfType -> "return to_nonconst<Type ## _t, Type>((Type *)" ++ callstr ++ ") ;"-          (CT _ctyp _isconst) -> "return "++callstr++";" -          (CT (CRef _) _) -> "return ((*)"++callstr++");"-          (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str-                                    ++">(("++str++"*)"++callstr++");" -            where str = class_name c' -          (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" -        funcDefStr = returnstr -    in  render tmpl [ ("returntype", rettypeToString toplevelvar_ret)  -                    , ("funcname", "TopLevel_" -                                   ++ maybe toplevelvar_name id toplevelvar_alias)-                    , ("funcbody", funcDefStr )-                    ] +  let tmpl = "$returntype $funcname ( ) { \n  $funcbody\n}" +      callstr = toplevelvar_name+      funcDefStr = returnCpp False (toplevelvar_ret) callstr+  in subst tmpl (context [ ("returntype", rettypeToString toplevelvar_ret               )  +                         , ("funcname"  , "TopLevel_" +                                          <> maybe toplevelvar_name id toplevelvar_alias)+                         , ("funcbody"  , funcDefStr                                    ) ])  +genTmplFunCpp :: Bool -- ^ is for simple type?+              -> TemplateClass+              -> TemplateFunction+              -> String +genTmplFunCpp b t@TmplCls {..} f = subst tmpl ctxt+ where+  tmpl = "#define ${tname}_${fname}${suffix}(Type) \\\n\+         \  extern \"C\" { \\\n\+         \    $decl; \\\n\+         \  } \\\n\+         \  inline $defn \\\n\+         \  auto a_${tname}_${fname}_ ## Type = ${tname}_${fname}_ ## Type  ;\n"+  ctxt = context . (("suffix",if b then "_s" else ""):) $+                   case f of+                     TFunNew {..} -> [ ("tname"  , tclass_name       )+                                     , ("fname"  , "new"             )+                                     , ("decl"   , tmplFunToDecl b t f )+                                     , ("defn"   , tmplFunToDef b t f  ) ]+                     TFun {..}    -> [ ("tname"  , tclass_name       )+                                     , ("fname"  , tfun_name         )+                                     , ("decl"   , tmplFunToDecl b t f )+                                     , ("defn"   , tmplFunToDef b t f  ) ]+                     TFunDelete   -> [ ("tname"  , tclass_name       )+                                     , ("fname"  , "delete"          )+                                     , ("decl"   , tmplFunToDecl b t f )+                                     , ("defn"   , tmplFunToDef b t f  ) ]++genTmplClassCpp :: Bool -- ^ is for simple type+                -> TemplateClass+                -> [TemplateFunction]+                -> String +genTmplClassCpp b TmplCls {..} fs = subst tmpl ctxt+ where+  tmpl = "#define ${tname}_instance${suffix}(Type) \\\n\+         \$macro\n"+  suffix = if b then "_s" else ""+  ctxt = context [ ("tname"  , tclass_name )+                 , ("suffix" , suffix      ) +                 , ("macro"  , macro       ) ]+  tname = tclass_name+  +  macro1 TFun {..}    = "  " <> tname<> "_" <> tfun_name <> suffix <> "(Type) \\"+                 +  macro1 TFunNew {..} = "  " <> tname<> "_new(Type) \\"+  macro1 TFunDelete   = "  " <> tname<> "_delete(Type) \\"                 +  macro = intercalateWith connRet macro1 fs+
lib/FFICXX/Generate/Code/Dependency.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Code.Dependency--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,34 +14,35 @@  module FFICXX.Generate.Code.Dependency where -import           Control.Applicative-import           Data.Function (on)+import           Data.Function             ( on )+import qualified Data.HashMap.Strict as HM import           Data.List  import           Data.Maybe-import qualified Data.HashMap.Strict as HM+import           Data.Monoid               ( (<>) ) import           System.FilePath  -- import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.Module import           FFICXX.Generate.Type.PackageInterface   -- |  mkPkgHeaderFileName ::Class -> HeaderName mkPkgHeaderFileName c = -    HdrName ((cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "h")+    HdrName ((cabal_cheaderprefix.class_cabal) c <> class_name c <.> "h")  -- |  mkPkgCppFileName ::Class -> String  mkPkgCppFileName c = -    (cabal_cheaderprefix.class_cabal) c ++ class_name c <.> "cpp"+    (cabal_cheaderprefix.class_cabal) c <> class_name c <.> "cpp"  -- |  mkPkgIncludeHeadersInH :: Class -> [HeaderName] mkPkgIncludeHeadersInH c =     let pkgname = (cabal_pkgname . class_cabal) c         extclasses = (filter ((/= pkgname) . cabal_pkgname . class_cabal) . mkModuleDepCpp) c-        extheaders = nub . map ((++"Type.h") .  cabal_pkgname . class_cabal) $ extclasses  -    in map mkPkgHeaderFileName (class_allparents c) ++ map HdrName extheaders+        extheaders = nub . map ((<>"Type.h") .  cabal_pkgname . class_cabal) $ extclasses  +    in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders                              @@ -54,23 +55,26 @@ mkCIH :: (Class->([Namespace],[HeaderName]))  -- ^ (mk namespace and include headers)         -> Class        -> ClassImportHeader-mkCIH mkNSandIncHdrs c = let r = ClassImportHeader c -                                   (mkPkgHeaderFileName c) -                                   ((fst . mkNSandIncHdrs) c)-                                   (mkPkgCppFileName c) -                                   (mkPkgIncludeHeadersInH c) -                                   (mkPkgIncludeHeadersInCPP c)-                                   ((snd . mkNSandIncHdrs) c)-                         in r +mkCIH mkNSandIncHdrs c = ClassImportHeader c +                           (mkPkgHeaderFileName c) +                           ((fst . mkNSandIncHdrs) c)+                           (mkPkgCppFileName c) +                           (mkPkgIncludeHeadersInH c) +                           (mkPkgIncludeHeadersInCPP c)+                           ((snd . mkNSandIncHdrs) c)   -- | extractClassFromType :: Types -> Maybe Class-extractClassFromType Void = Nothing-extractClassFromType SelfType = Nothing-extractClassFromType (CT _ _) = Nothing-extractClassFromType (CPT (CPTClass c) _) = Just c-extractClassFromType (CPT (CPTClassRef c) _) = Just c+extractClassFromType Void                     = Nothing+extractClassFromType SelfType                 = Nothing+extractClassFromType (CT _ _)                 = Nothing+extractClassFromType (CPT (CPTClass c) _)     = Just c+extractClassFromType (CPT (CPTClassRef c) _)  = Just c+extractClassFromType (CPT (CPTClassCopy c) _) = Just c+extractClassFromType (TemplateApp _ _ _)      = Nothing+extractClassFromType (TemplateType _)         = Nothing+extractClassFromType (TemplateParam _)        = Nothing   -- | class dependency for a given function @@ -112,7 +116,7 @@       pkgname = (cabal_pkgname . class_cabal) c        extclasses = (filter (\x-> x /= c && ((/= pkgname) . cabal_pkgname . class_cabal) x) . concatMap (argumentDependency.extractClassDep)) fs       parents = class_parents c -  in  nub (parents ++ extclasses) +  in  nub (parents <> extclasses)    -- | @@ -128,14 +132,14 @@   let fs = class_funcs c    in  nub . filter (/= c)  $          mapMaybe (returnDependency.extractClassDep) fs   -        ++ concatMap (argumentDependency.extractClassDep) fs-        ++ (class_parents c) +        <> concatMap (argumentDependency.extractClassDep) fs+        <> (class_parents c)   -- |  mkModuleDepFFI4One :: Class -> [Class]  mkModuleDepFFI4One c =    let fs = class_funcs c -  in  (++) <$> mapMaybe (returnDependency.extractClassDep)  +  in  (<>) <$> mapMaybe (returnDependency.extractClassDep)              <*> concatMap (argumentDependency.extractClassDep)        $ fs @@ -143,50 +147,52 @@ mkModuleDepFFI :: Class -> [Class]  mkModuleDepFFI c =    let ps = class_allparents c -      alldeps' = (concatMap mkModuleDepFFI4One ps) ++ mkModuleDepFFI4One c-      alldeps = nub (filter (/= c) alldeps')-  in  alldeps-+      alldeps' = (concatMap mkModuleDepFFI4One ps) <> mkModuleDepFFI4One c+  in nub (filter (/= c) alldeps')                      mkClassModule :: (Class->([Namespace],[HeaderName]))+              -> [(String,[String])]               -> Class                -> ClassModule -mkClassModule mkincheaders c = -    let r = (ClassModule <$> getClassModuleBase  -                 <*> pure-                 <*> return . mkCIH mkincheaders-                 <*> highs_nonsource  -                 <*> raws -                 <*> highs_source-                 <*> ffis -            ) c-    in r -    -  where highs_nonsource = map getClassModuleBase . mkModuleDepHighNonSource-        raws = map getClassModuleBase . mkModuleDepRaw -        highs_source = map getClassModuleBase . mkModuleDepHighSource-        ffis = map getClassModuleBase . mkModuleDepFFI +mkClassModule mkincheaders extra c =+  ClassModule (getClassModuleBase c) [c] (map (mkCIH mkincheaders) [c]) highs_nonsource+              raws highs_source ffis extraimports +  where highs_nonsource = (map getClassModuleBase . mkModuleDepHighNonSource) c+        raws = (map getClassModuleBase . mkModuleDepRaw) c+        highs_source = (map getClassModuleBase . mkModuleDepHighSource) c+        ffis = (map getClassModuleBase . mkModuleDepFFI) c+        extraimports = fromMaybe [] (lookup (class_name c) extra) ++ mkClassNSHeaderFromMap :: HM.HashMap String ([Namespace],[HeaderName]) -> Class -> ([Namespace],[HeaderName]) mkClassNSHeaderFromMap m c = fromMaybe ([],[]) (HM.lookup (class_name c) m) -mkAll_ClassModules_CIH_TIH :: (String,Class->([Namespace],[HeaderName])) -- ^ (package name,mkIncludeHeaders)-                        -> ([Class],[TopLevelFunction]) -                        -> ([ClassModule],[ClassImportHeader],TopLevelImportHeader)-mkAll_ClassModules_CIH_TIH (pkgname,mkNSandIncHdrs) (cs,fs) = -  let ms = map (mkClassModule mkNSandIncHdrs) cs ++mkTCM :: (TemplateClass,HeaderName) -> TemplateClassModule +mkTCM (t,hdr) = TCM  (getTClassModuleBase t) [t] [TCIH t hdr]+++mkPackageConfig+  :: (String,Class->([Namespace],[HeaderName])) -- ^ (package name,mkIncludeHeaders)+  -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])]) +  -> PackageConfig+mkPackageConfig (pkgname,mkNS_IncHdrs) (cs,fs,ts,extra) = +  let ms = map (mkClassModule mkNS_IncHdrs extra) cs        cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)       cihs = nubBy cmpfunc (concatMap cmCIH ms)       -- for toplevel        tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs        tl_cs2 = mapMaybe (returnDependency . extractClassDepForTopLevelFunction) fs -      tl_cs = nubBy ((==) `on` class_name) (tl_cs1 ++ tl_cs2)+      tl_cs = nubBy ((==) `on` class_name) (tl_cs1 <> tl_cs2)       tl_cihs = catMaybes $          foldr (\c acc-> (find (\x -> (class_name . cihClass) x == class_name c) cihs):acc) [] tl_cs        -- -      tih = TopLevelImportHeader (pkgname ++ "TopLevel") tl_cihs fs -  in (ms,cihs,tih)+      tih = TopLevelImportHeader (pkgname <> "TopLevel") tl_cihs fs+      tcms = map mkTCM ts+      tcihs = concatMap tcmTCIH tcms+  in PkgConfig ms cihs tih tcms tcihs   mkHSBOOTCandidateList :: [ClassModule] -> [String]
lib/FFICXX/Generate/Code/HsFFI.hs view
@@ -1,9 +1,10 @@+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Code.HsFFI--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,97 +15,50 @@  module FFICXX.Generate.Code.HsFFI where -import Data.Char (toLower)-import System.FilePath ((<.>))+import           Data.Maybe                              ( fromMaybe, mapMaybe )+import           Data.Monoid                             ( (<>) )+import           Language.Haskell.Exts.Syntax            ( Decl(..) )+import           System.FilePath ((<.>)) -- -import FFICXX.Generate.Util -import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.PackageInterface+import           FFICXX.Generate.Util+import           FFICXX.Generate.Util.HaskellSrcExts+import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.Module+import           FFICXX.Generate.Type.PackageInterface -genHsFFI :: ClassImportHeader -> String +genHsFFI :: ClassImportHeader -> [Decl] genHsFFI header =   let c = cihClass header       h = cihSelfHeader header       allfns = concatMap (virtualFuncs . class_funcs)                           (class_allparents c)-               ++ (class_funcs c) -  in  intercalateWith connRet2 (hsFFIClassFunc h c) allfns  --genAllHsFFI :: [ClassImportHeader] -> String -genAllHsFFI = intercalateWith connRet2 genHsFFI +               <> (class_funcs c) +  in mapMaybe (hsFFIClassFunc h c) allfns  -------- --- | this template will be deprecated -ffistub :: String-ffistub = "foreign import ccall \"$headerfilename$ $classname$_$funcname$\" $hsfuncname$ \n  :: $hsargs$"---- | this template will be used.-ffiTemplate :: String-ffiTemplate = "foreign import ccall \"$headerfilename$ $funcname$\" $hsfuncname$ \n  :: $hsargs$"---hsFFIClassFunc :: HeaderName -> Class -> Function -> String -hsFFIClassFunc headerfilename c f = if isAbstractClass c -                       then ""-                       else if (isNewFunc f || isStaticFunc f)-                              then render ffistub -                                       [ ("headerfilename",(unHdrName headerfilename))-                                       , ("classname",class_name c)-                                       , ("funcname", aliasedFuncName c f)-                                       , ("hsfuncname",hscFuncName c f)-                                       , ("hsargs", hsFuncTypNoSelf c f) ] -                              else render ffistub -                                       [ ("headerfilename",(unHdrName headerfilename))-                                       , ("classname",class_name c)-                                       , ("funcname", aliasedFuncName c f)-                                       , ("hsfuncname",hscFuncName c f)-                                       , ("hsargs", hsFuncTyp c f) ] -+hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe Decl+hsFFIClassFunc headerfilename c f =+  if isAbstractClass c +  then Nothing+  else let hfile = unHdrName headerfilename+           cname = class_name c <> "_" <> aliasedFuncName c f+           typ = if (isNewFunc f || isStaticFunc f)+                 then hsFFIFuncTyp (Just (NoSelf,c)) (genericFuncArgs f, genericFuncRet f)+                 else hsFFIFuncTyp (Just (Self,c)  ) (genericFuncArgs f, genericFuncRet f)+       in Just (mkForImpCcall (hfile <> " " <> cname) (hscFuncName c f) typ)+          ---------------------------- -- for top level function --  ---------------------------- -genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> String -genTopLevelFuncFFI header tfn =-    case tfn of-      TopLevelFunction {..} ->  -	let fname = maybe toplevelfunc_name id toplevelfunc_alias-	    (x:xs)  = fname-	    headerfilename = tihHeaderFileName header <.> "h"-	    hfname = toLower x : xs -	    cfname = "c_" ++ toLowers hfname -	    args = toplevelfunc_args -	    ret = toplevelfunc_ret         -	    argstr = concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret -	in render ffiTemplate-	     [ ("headerfilename",headerfilename) -	     , ("funcname", "TopLevel_" ++ fname)-	     , ("hsfuncname",cfname)-	     , ("hsargs", argstr) ] -      TopLevelVariable {..} ->  -	let fname = maybe toplevelvar_name id toplevelvar_alias-	    (x:xs)  = fname-	    headerfilename = tihHeaderFileName header <.> "h"-	    hfname = toLower x : xs -	    cfname = "c_" ++ toLowers hfname -	    args = [] -	    ret = toplevelvar_ret         -	    argstr = concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret -	in render ffiTemplate-	     [ ("headerfilename",headerfilename) -	     , ("funcname", "TopLevel_" ++ fname)-	     , ("hsfuncname",cfname)-	     , ("hsargs", argstr) ] --  where hsargtype (CT ctype _) = hsCTypeName ctype-        hsargtype (CPT x _) = hsCppTypeName x -        hsargtype SelfType = "genTopLevelFuncFFI : no self for top level function " -        hsargtype _ = error "undefined hsargtype"--        hsrettype Void = "IO ()"-        hsrettype SelfType = "genTopLevelFuncFFI : no self for top level function "-        hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype-        hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x -+genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl+genTopLevelFuncFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ+  where (fname,args,ret) =+          case tfn of+            TopLevelFunction {..} -> (fromMaybe toplevelfunc_name toplevelfunc_alias, toplevelfunc_args, toplevelfunc_ret)+            TopLevelVariable {..} -> (fromMaybe toplevelvar_name toplevelvar_alias, [], toplevelvar_ret)+        hfilename = tihHeaderFileName header <.> "h"+        cfname = "c_" <> toLowers fname+        typ =hsFFIFuncTyp Nothing (args,ret)
lib/FFICXX/Generate/Code/HsFrontEnd.hs view
@@ -1,10 +1,11 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}  ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Code.HsFrontEnd--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,27 +16,36 @@  module FFICXX.Generate.Code.HsFrontEnd where -import Control.Monad.State-import Control.Monad.Reader-import Data.Char (toLower)-import Data.List-import qualified Data.Map as M-import Data.Maybe-import System.FilePath ((<.>))+import           Control.Monad.State+import           Control.Monad.Reader+import           Data.List+import           Data.Monoid                             ( (<>) )+import           Language.Haskell.Exts.Syntax            ( Asst(..), Binds(..), Boxed(..), Bracket(..)+                                                         , ClassDecl(..), DataOrNew(..), Decl(..)+                                                         , Exp(..), ExportSpec(..)+                                                         , ImportDecl(..), InstDecl(..), Literal(..)+                                                         , Name(..), Namespace(..), Pat(..)+                                                         , QualConDecl(..), Stmt(..)+                                                         , Type(..), TyVarBind (..)+                                                         )+import           Language.Haskell.Exts.SrcLoc            ( noLoc )+import           System.FilePath                         ((<.>)) -- -import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Annotate-import FFICXX.Generate.Type.Module-import FFICXX.Generate.Util+import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.Annotate+import           FFICXX.Generate.Type.Module+import           FFICXX.Generate.Util+import           FFICXX.Generate.Util.HaskellSrcExts  + mkComment :: Int -> String -> String mkComment indent str    | (not.null) str =      let str_lines = lines str         indentspace = replicate indent ' '          commented_lines = -          (indentspace ++ "-- | "++head str_lines) : map (\x->indentspace ++ "--   "++x) (tail str_lines)+          (indentspace <> "-- | "<>head str_lines) : map (\x->indentspace <> "--   "<>x) (tail str_lines)      in unlines commented_lines    | otherwise = str                 @@ -44,538 +54,347 @@   | (not.null) str =      let str_lines = lines str          commented_lines = -          ("-- ^ "++head str_lines) : map (\x->"--   "++x) (tail str_lines)+          ("-- ^ "<>head str_lines) : map (\x->"--   "<>x) (tail str_lines)      in unlines commented_lines    | otherwise = str                 -                        ----------------- --- |-hsModuleDeclTmpl :: String -hsModuleDeclTmpl = "module $moduleName$ $moduleExp$ where"---- |-genModuleDecl :: Module -> Reader AnnotateMap String -genModuleDecl m = do -  let modheader = render hsModuleDeclTmpl [ ("moduleName", module_name m) -                                          , ("moduleExp", mkModuleExports m) ] -  return (modheader)---------------------- |-classprefix :: Class -> String -classprefix c = let ps = (map typeclassName . class_parents) c-                in  if null ps -                    then "" -                    else "(" ++ intercalate "," (map (++ " a") ps) ++ ") => "---- |-hsClassDeclHeaderTmpl :: String-hsClassDeclHeaderTmpl = "$classann$\nclass $constraint$$classname$ a where"--genHsFrontDecl :: Class -> Reader AnnotateMap String -genHsFrontDecl c = do -  amap <- ask  -  let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap -  let header = render hsClassDeclHeaderTmpl [ ("classname", typeclassName c ) -                                            , ("constraint", classprefix c) -                                            , ("classann",   mkComment 0 cann) ] -      bodyline func = -        let fname = hsFuncName c func -            mann = maybe "" id $ M.lookup (PkgMethod,fname) amap-        in  render hsClassDeclFuncTmpl -                                    [ ("funcname", hsFuncName c func) -                                    , ("args" , prefixstr func ++ argstr func )-                                    , ("funcann", mkComment 4 mann)  -                                    ] -      prefixstr func =  -        let prefixlst = (snd . mkHsFuncArgType . genericFuncArgs) func-                        ++ (snd . mkHsFuncRetType . genericFuncRet ) func-        in  if null prefixlst-              then "" -              else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => "  -                  -      argstr func = intercalateWith connArrow id $-                      [ "a" ] -                      ++ fst (mkHsFuncArgType (genericFuncArgs func))-                      ++ ["IO " ++ (fst . mkHsFuncRetType . genericFuncRet) func]  -      bodylines = map bodyline . virtualFuncs -                      $ (class_funcs c) -  return $ intercalateWith connRet id (header : bodylines) ----genAllHsFrontDecl :: [Class] -> Reader AnnotateMap String -genAllHsFrontDecl = intercalateWithM connRet2 genHsFrontDecl+genHsFrontDecl :: Class -> Reader AnnotateMap Decl+genHsFrontDecl c = do+  -- for the time being, let's ignore annotation.+  -- amap <- ask  +  -- let cann = maybe "" id $ M.lookup (PkgClass,class_name c) amap +  let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body+      sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f)+      body = map (ClsDecl . sigdecl) . virtualFuncs . class_funcs $ c +  return cdecl  ------------------- --genHsFrontInst :: Class -> Class -> String +genHsFrontInst :: Class -> Class -> [Decl] genHsFrontInst parent child     | (not.isAbstractClass) child = -    let headline = "instance " ++ typeclassName parent ++ " " ++ (fst.hsClassName) child ++ " where" -        defline func = "  " ++ hsFuncName child func ++ " = " ++ hsFuncXformer func ++ " " ++ hscFuncName child func -        deflines = (map defline) . virtualFuncs . class_funcs $ parent --    in  intercalateWith connRet id (headline : deflines) -  | otherwise = ""+    let idecl = mkInstance [] (typeclassName parent) [convertCpp2HS (Just child) SelfType] body+        defn f = mkBind1 (hsFuncName child f) [] rhs Nothing +          where rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))+        body = map (InsDecl . defn) . virtualFuncs . class_funcs $ parent+    in [idecl]+  | otherwise = []                 ---------------------- -hsClassInstExistCommonTmpl :: String -hsClassInstExistCommonTmpl = "instance FPtr (Exist $highname$) where\n  type Raw (Exist $highname$) = $rawname$\n  get_fptr ($existConstructor$ obj) = castForeignPtr (get_fptr obj)\n  cast_fptr_to_obj fptr = $existConstructor$ (cast_fptr_to_obj (fptr :: ForeignPtr $rawname$) :: $highname$)" ---genHsFrontInstExistCommon :: Class -> String -genHsFrontInstExistCommon c = render hsClassInstExistCommonTmpl tmplName-  where (highname,rawname) = hsClassName c-        iname = typeclassName c -        ename = existConstructorName c-        tmplName = [ ("rawname",rawname)-                   , ("highname",highname)-                   , ("interfacename",iname)-                   , ("existConstructor",ename)-                   ] --genAllHsFrontInstExistCommon :: [Class] -> String -genAllHsFrontInstExistCommon cs = intercalateWith connRet2 genHsFrontInstExistCommon cs-----------------------hsClassInstExistVirtualTmpl :: String -hsClassInstExistVirtualTmpl = "instance $Iparent$ (Exist $child$) where\n$method$"--hsClassInstExistVirtualMethodNoSelfTmpl :: String -hsClassInstExistVirtualMethodNoSelfTmpl = "  $methodname$ ($exist$ x) = $methodname$ x"--hsClassInstExistVirtualMethodSelfTmpl :: String -hsClassInstExistVirtualMethodSelfTmpl = "  $methodname$ ($exist$ x) $args$ = return . $exist$ =<< $methodname$ x $args$"---genHsFrontInstExistVirtual :: Class -> Class -> String -genHsFrontInstExistVirtual p c = render hsClassInstExistVirtualTmpl tmplName-  where methodstr = intercalateWith connRet (genHsFrontInstExistVirtualMethod p c)  -                                            (virtualFuncs.class_funcs $ p)-        tmplName = [ ("Iparent",typeclassName p)-                   , ("child", (fst.hsClassName) c)-                   , ("method", methodstr )-                   ] --genHsFrontInstExistVirtualMethod :: Class -> Class -> Function -> String -genHsFrontInstExistVirtualMethod p c f =-    case f of-      Constructor _  _ -> error "error in genHsFrontInstExistVirtualMethod"  -      Destructor _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName-      _ -> case func_ret f of-             SelfType -> render hsClassInstExistVirtualMethodSelfTmpl (tmplName++args)-             _ -> render hsClassInstExistVirtualMethodNoSelfTmpl tmplName-  where tmplName = [ ("methodname", hsFuncName p f)-                   , ("exist", existConstructorName c) ]-        args  = [ ("args", intercalate " " (take (length (func_args f)) (map (\x -> 'a':(show x)) ([1..] :: [Int]) )))]--genAllHsFrontInstExistVirtual :: [Class] -> DaughterMap -> String -genAllHsFrontInstExistVirtual cs _dmap = intercalateWith connRet2 allinstances cs-  where allinstances c = -          let ps = c : class_allparents c-          in  intercalateWith connRet2 (\p->genHsFrontInstExistVirtual p c) ps -- ---------------------  genHsFrontInstNew :: Class         -- ^ only concrete class -                    -> Reader AnnotateMap (Maybe String)+                  -> Reader AnnotateMap [Decl] genHsFrontInstNew c = do -  amap <- ask -  if null newfuncs -    then return Nothing-    else do -      let newfunc = head newfuncs-          cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap-          newfuncann = mkComment 0 cann-          newlinehead = constructorName c ++ " :: " ++ argstr newfunc -          newlinebody = constructorName c ++ " = " -                              ++ hsFuncXformer newfunc ++ " " -                              ++ hscFuncName c newfunc -          argstr func = intercalateWith connArrow id $-                          map (ctypToHsTyp (Just c) . fst) (genericFuncArgs func)-                          ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) func]-          newline = newfuncann ++ "\n" ++ newlinehead ++ "\n" ++ newlinebody -      return (Just newline)-  where newfuncs = filter isNewFunc (class_funcs c)  +  -- amap <- ask+  let fs = filter isNewFunc (class_funcs c)+  return . flip concatMap fs $ \f ->+    let+        -- for the time being, let's ignore annotation.+        -- cann = maybe "" id $ M.lookup (PkgMethod, constructorName c) amap+        -- newfuncann = mkComment 0 cann+        rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+    in mkFun (constructorName c) (functionSignature c f) [] rhs Nothing -genAllHsFrontInstNew :: [Class]    -- ^ only concrete class -                     -> Reader AnnotateMap String -genAllHsFrontInstNew = liftM (intercalate "\n\n") . liftM catMaybes . mapM genHsFrontInstNew -  -genHsFrontInstNonVirtual :: Class -> Maybe String -genHsFrontInstNonVirtual c -  | (not.null) nonvirtualFuncs  =                        -    let header f = (aliasedFuncName c f) ++ " :: " ++ argstr f-        body f  = (aliasedFuncName c f)  ++ " = " ++ hsFuncXformer f ++ " " ++ hscFuncName c f -        argstr func = intercalateWith connArrow id $ -                        [(fst.hsClassName) c]  -                        ++ map (ctypToHsTyp (Just c) . fst) (genericFuncArgs func)-                        ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) func] -    in  Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) nonvirtualFuncs-  | otherwise = 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) -genAllHsFrontInstNonVirtual :: [Class] -> String -genAllHsFrontInstNonVirtual = intercalate "\n\n" . map fromJust . filter isJust . map genHsFrontInstNonVirtual- ----- -genHsFrontInstStatic :: Class -> Maybe String -genHsFrontInstStatic c -  | (not.null) fs =                        -    let header f = (aliasedFuncName c f) ++ " :: " ++ argstr f-        body f  = (aliasedFuncName c f)  ++ " = " ++ hsFuncXformer f ++ " " ++ hscFuncName c f -        argstr f = intercalateWith connArrow id $ -                     map (ctypToHsTyp (Just c) . fst) (genericFuncArgs f)-                     ++ ["IO " ++ (ctypToHsTyp (Just c) . genericFuncRet) f] -    in  Just $ intercalateWith connRet2 (\f -> header f ++ "\n" ++ body f) fs-  | otherwise = Nothing   - where fs = staticFuncs (class_funcs c)+genHsFrontInstStatic :: Class -> [Decl]+genHsFrontInstStatic c =+  flip concatMap (staticFuncs (class_funcs c)) $ \f ->+    let rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+    in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing  ----- -genHsFrontInstCastable :: Class -> String +castBody :: [InstDecl]+castBody =+  [ InsDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (App (mkVar "f") (App (mkVar "castPtr") (App (mkVar "get_fptr") (mkVar "x")))) Nothing)+  , InsDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (App (mkVar "f") (App (mkVar "cast_fptr_to_obj") (App (mkVar "castPtr") (mkVar "x")))) Nothing)+  ]++genHsFrontInstCastable :: Class -> Maybe Decl genHsFrontInstCastable c    | (not.isAbstractClass) c =      let iname = typeclassName c         (_,rname) = hsClassName c-    in  render hsInterfaceCastableInstanceTmpl -               [("interfaceName",iname),("rawClassName",rname)]-  | otherwise = "" --genAllHsFrontInstCastable :: [Class] -> String -genAllHsFrontInstCastable = -  intercalateWith connRet2 genHsFrontInstCastable+        a = mkTVar "a"+        ctxt = [ ClassA (unqual iname) [a], ClassA (unqual "FPtr") [a] ]+    in Just (mkInstance ctxt "Castable" [a,TyApp tyPtr (tycon rname)] castBody)+  | otherwise = Nothing -genHsFrontInstCastableSelf :: Class -> String +genHsFrontInstCastableSelf :: Class -> Maybe Decl genHsFrontInstCastableSelf c    | (not.isAbstractClass) c =      let (cname,rname) = hsClassName c-    in  render hsInterfaceCastableInstanceSelfTmpl -               [("className",cname)-               ,("rawClassName",rname)]-  | otherwise = "" +    in Just (mkInstance [] "Castable" [tycon cname, TyApp tyPtr (tycon rname)] castBody)+  | otherwise = Nothing   -------------------------- -rawToHighDecl :: String-rawToHighDecl = "data $rawname$\nnewtype $highname$ = $highname$ (ForeignPtr $rawname$) deriving (Eq, Ord, Show)"--rawToHighInstance :: String-rawToHighInstance = "instance FPtr $highname$ where\n   type Raw $highname$ = $rawname$\n   get_fptr ($highname$ fptr) = fptr\n   cast_fptr_to_obj = $highname$"---existableInstance :: String -existableInstance = "instance Existable $highname$ where\n  data Exist $highname$ = forall a. (FPtr a, $interfacename$ a) => $existConstructor$ a"---hsClassRawType :: Class -> String -hsClassRawType c = -    let decl = render rawToHighDecl tmplName-        inst1 = render rawToHighInstance tmplName-    in  decl `connRet` inst1 -  where (highname,rawname) = hsClassName c-        iname = typeclassName c -        -- ename = existConstructorName c-        tmplName = [ ("rawname",rawname)-                   , ("highname",highname)-                   , ("interfacename",iname)-                   ] --hsClassExistType :: Class -> String -hsClassExistType c = render existableInstance tmplName-  where (highname,_rawname) = hsClassName c-        iname = typeclassName c -        ename = existConstructorName c-        tmplName = [ ("existConstructor",ename) -                   , ("highname",highname)-                   , ("interfacename",iname)-                   ]--hsClassDeclFuncTmpl :: String-hsClassDeclFuncTmpl = "$funcann$\n    $funcname$ :: $args$ "---hsArgs :: Class -> Args -> String-hsArgs c = intercalateWith connArrow (ctypToHsTyp (Just c) . fst) --mkHsFuncArgType :: Args -> ([String],[String]) -mkHsFuncArgType lst = -  let  (args,st) = runState (mapM mkFuncArgTypeWorker lst) ([],(0 :: Int))-  in   (args,fst st)-  where mkFuncArgTypeWorker (typ,_var) = -          case typ of                  -            SelfType -> return "a"-            CT _ _   -> return $ ctypToHsTyp Nothing typ -            CPT (CPTClass c') _ -> do -              (prefix,n) <- get -              let cname = (fst.hsClassName) c' -                  iname = typeclassNameFromStr cname -                  newname = 'c' : show n-                  newprefix1 = iname ++ " " ++ newname    -                  newprefix2 = "FPtr " ++ newname-              put (newprefix1:newprefix2:prefix,n+1)-              return newname-            CPT (CPTClassRef c') _ -> do -              (prefix,n) <- get -              let cname = (fst.hsClassName) c' -                  iname = typeclassNameFromStr cname -                  newname = 'c' : show n-                  newprefix1 = iname ++ " " ++ newname    -                  newprefix2 = "FPtr " ++ newname-              put (newprefix1:newprefix2:prefix,n+1)-              return newname-            _ -> error ("No such c type : " ++ show typ)  --mkHsFuncRetType :: Types -> (String,[String])-mkHsFuncRetType rtyp = -  case rtyp of -    SelfType -> ("a",[])-    CPT (CPTClass c') _ -> (cname,[]) where cname = (fst.hsClassName) c' -    CPT (CPTClassRef c') _ -> (cname,[]) where cname = (fst.hsClassName) c' -    _ -> (ctypToHsTyp Nothing rtyp,[])-+hsClassRawType :: Class -> [Decl]+hsClassRawType c =+  [ mkData    rawname [] [] []+  , mkNewtype highname []+      [ QualConDecl noLoc [] []+          (conDecl highname [TyApp tyPtr rawtype])+      ]+      derivs+  , mkInstance [] "FPtr" [hightype]+      [ InsType noLoc (TyApp (tycon "Raw") hightype) rawtype+      , InsDecl (mkBind1 "get_fptr" [PApp (unqual highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)+      , InsDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing)+      ]       -----------                        --hsInterfaceCastableInstanceTmpl :: String -hsInterfaceCastableInstanceTmpl = -  "instance ($interfaceName$ a, FPtr a) => Castable a (Ptr $rawClassName$) where\n  cast = unsafeForeignPtrToPtr . castForeignPtr . get_fptr\n  uncast = cast_fptr_to_obj . castForeignPtr . unsafePerformIO . newForeignPtr_ \n"--hsInterfaceCastableInstanceSelfTmpl :: String -hsInterfaceCastableInstanceSelfTmpl = -  "instance Castable $className$ (Ptr $rawClassName$) where\n  cast = unsafeForeignPtrToPtr . castForeignPtr . get_fptr\n  uncast = cast_fptr_to_obj . castForeignPtr . unsafePerformIO . newForeignPtr_ \n"---------------hsExistentialGADTBodyTmpl :: String -hsExistentialGADTBodyTmpl = "    GADT$mother$$daughter$ :: $daughter$ -> GADTType $mother$ $daughter$"+  ]+ where (highname,rawname) = hsClassName c+       hightype = tycon highname+       rawtype = tycon rawname+       derivs = [(unqual "Eq",[]),(unqual "Ord",[]),(unqual "Show",[])]  -hsExistentialCastBodyTmpl :: String-hsExistentialCastBodyTmpl = "    \"$daughter$\" -> case obj of\n        $mother$ fptr -> let obj' = $daughter$ (castForeignPtr fptr :: ForeignPtr Raw$daughter$)\n                        in  return . EGADT$mother$ . GADT$mother$$daughter$ \\$ obj'"- ------------ -- upcast -- ------------ -genHsFrontUpcastClass :: Class -> Reader AnnotateMap String-genHsFrontUpcastClass c = do -  -- amap <- ask -  let (highname,rawname) = hsClassName c-      upcaststr = render hsUpcastClassTmpl [ ("classname", highname) -                                           , ("ifacename", typeclassName c)-                                           , ("rawclassname", rawname)  -                                           , ("space", replicate (length highname+11) ' ' ) ] -  return upcaststr--genAllHsFrontUpcastClass :: [Class] -> Reader AnnotateMap String-genAllHsFrontUpcastClass = intercalateWithM connRet2 genHsFrontUpcastClass---hsUpcastClassTmpl :: String -hsUpcastClassTmpl =  "upcast$classname$ :: (FPtr a, $ifacename$ a) => a -> $classname$\nupcast$classname$ h = let fh = get_fptr h\n$space$    fh2 :: ForeignPtr $rawclassname$ = castForeignPtr fh\n$space$in cast_fptr_to_obj fh2"+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 (Ident "a")+        a_tvar = mkTVar "a"+        typ = TyForall (Just [a_bind])+                [ClassA (unqual "FPtr") [a_tvar], ClassA (unqual iname) [a_tvar]]+                (TyFun a_tvar hightype)+        rhs = Let (BDecls+                    [ 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 -> Reader AnnotateMap String-genHsFrontDowncastClass c = do -  let (highname,rawname) = hsClassName c-      downcaststr = render hsDowncastClassTmpl [ ("classname", highname) -                                               , ("ifacename", typeclassName c)-                                               , ("rawclassname", rawname)  -                                               , ("space", replicate (length highname+13) ' ' ) ] -  return downcaststr+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 (Ident "a")+        a_tvar = mkTVar "a"+        typ = TyForall (Just [a_bind])+                [ClassA (unqual "FPtr") [a_tvar], ClassA (unqual iname) [a_tvar]]+                (TyFun hightype a_tvar)+        rhs = Let (BDecls+                    [ 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") -genAllHsFrontDowncastClass :: [Class] -> Reader AnnotateMap String-genAllHsFrontDowncastClass = intercalateWithM connRet2 genHsFrontDowncastClass +------------------------+-- Top Level Function --+------------------------ -hsDowncastClassTmpl :: String -hsDowncastClassTmpl =  "downcast$classname$ :: (FPtr a, $ifacename$ a) => $classname$ -> a \ndowncast$classname$ h = let fh = get_fptr h\n$space$    fh2 = castForeignPtr fh\n$space$in cast_fptr_to_obj fh2"+genTopLevelFuncDef :: TopLevelFunction -> [Decl]+genTopLevelFuncDef f@TopLevelFunction {..} = +    let fname = hsFrontNameForTopLevelFunction f+        (typs,ctxts) = extractArgRetTypes Nothing False (toplevelfunc_args,toplevelfunc_ret)+        -- rtyp = (tycon . ctypToHsTyp Nothing) toplevelfunc_ret+        sig = TyForall Nothing ctxts (foldr1 TyFun typs)+        xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull"+        cfname = "c_" <> toLowers fname +        rhs = App (mkVar xformerstr) (mkVar cfname)+        +    in mkFun fname sig [] rhs Nothing +genTopLevelFuncDef v@TopLevelVariable {..} = +    let fname = hsFrontNameForTopLevelFunction v+        cfname = "c_" <> toLowers fname +        rtyp = (tycon . ctypToHsTyp Nothing) toplevelvar_ret+        sig = TyApp (tycon "IO") rtyp+        rhs = App (mkVar "xformnull") (mkVar cfname)+        +    in mkFun fname sig [] rhs Nothing  + ------------ -- Export -- ------------ -genExport :: Class -> String +genExport :: Class -> [ExportSpec] genExport c =-    let methodstr = if null . (filter isVirtualFunc) $ (class_funcs c) -                      then ""-                      else "(..)"+    let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) +                    then EAbs NoNamespace (unqual n)+                    else EThingAll (unqual n)     in if isAbstractClass c -         then "    " ++ typeclassName c ++ methodstr -         else "    " ++ (fst.hsClassName) c ++ "(..)\n  , " -                     ++ typeclassName c ++ methodstr-                     ++ "\n  , upcast" ++ (fst.hsClassName) c -                     ++ "\n  , downcast" ++ (fst.hsClassName) c -                     ++ "\n" ++ genExportConstructorAndNonvirtual c -                     ++ "\n" ++ genExportStatic 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 -> String -genExportConstructorAndNonvirtual c =         -    intercalateWith connRet (\x->indent++", "++x) fns-  where indent = replicate 2 ' ' -        fs = class_funcs c+genExportConstructorAndNonvirtual :: Class -> [ExportSpec]+genExportConstructorAndNonvirtual c = map (EVar . unqual) fns+  where fs = class_funcs c         fns = map (aliasedFuncName c) (constructorFuncs fs -                                       ++ nonVirtualNotNewFuncs fs)+                                       <> nonVirtualNotNewFuncs fs)  -- | staic function export list -genExportStatic :: Class -> String -genExportStatic c =         -    intercalateWith connRet (\x->indent++", "++x) fns-  where indent = replicate 2 ' ' -        fs = class_funcs c+genExportStatic :: Class -> [ExportSpec]+genExportStatic c = map (EVar . unqual) fns+  where fs = class_funcs c         fns = map (aliasedFuncName c) (staticFuncs fs)   ----genExportList :: [Class] -> String -genExportList = concatMap genExport --importOneClass :: String -> String -> String -importOneClass mname typ = "import " ++ mname <.> typ --importSOURCEOneClass :: String -> String -> String -importSOURCEOneClass mname typ = "import {-# SOURCE #-} " ++ mname <.> typ ---genImportInModule :: [Class] -> String -genImportInModule cs = -  let genImportOneClass c = -        let n = getClassModuleBase c -        in  intercalateWith connRet (importOneClass n) $-              ["RawType", "Interface", "Implementation"]-  in  intercalate "\n" (map genImportOneClass cs)+genExtraImport :: ClassModule -> [ImportDecl]+genExtraImport cm = map mkImport (cmExtraImport cm)  -genImportInFFI :: ClassModule -> String-genImportInFFI m = -  let modlst = cmImportedModulesForFFI m-  in  intercalateWith connRet (\x->importOneClass x "RawType") modlst+genImportInModule :: [Class] -> [ImportDecl]+genImportInModule = concatMap (\x -> map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"]) +genImportInFFI :: ClassModule -> [ImportDecl]+genImportInFFI = map (\x->mkImport (x <.> "RawType")) . cmImportedModulesForFFI -genImportInInterface :: ClassModule -> String+genImportInInterface :: ClassModule -> [ImportDecl] genImportInInterface m =    let modlstraw = cmImportedModulesRaw m       modlstparent = cmImportedModulesHighNonSource m        modlsthigh = cmImportedModulesHighSource m-      getImportOneClassRaw mname = -        intercalateWith connRet (importOneClass mname) ["RawType"]-      getImportOneClassHigh mname = -        intercalateWith connRet (importOneClass mname) ["Interface"]-      getImportSOURCEOneClassHigh mname = -        intercalateWith connRet (importSOURCEOneClass mname) ["Interface"]-  in  importOneClass (cmModule m) "RawType"-      `connRet`-      intercalateWith connRet getImportOneClassRaw modlstraw-      `connRet`-      intercalateWith connRet getImportOneClassHigh modlstparent -      `connRet` -      "---- ============ ----" -      `connRet` -      intercalateWith connRet getImportSOURCEOneClassHigh modlsthigh+  in  [mkImport (cmModule m <.> "RawType")]+      <> map (\x -> mkImport (x<.>"RawType")) modlstraw+      <> map (\x -> mkImport (x<.>"Interface")) modlstparent +      <> map (\x -> mkImportSrc (x<.>"Interface")) modlsthigh  -- |-genImportInCast :: ClassModule -> String -genImportInCast m = -    importOneClass (cmModule m) "RawType"-    `connRet` -    importOneClass (cmModule m) "Interface"+genImportInCast :: ClassModule -> [ImportDecl]+genImportInCast m = [ mkImport (cmModule m <.> "RawType")+                   ,  mkImport (cmModule m <.> "Interface") ]  -- | -genImportInImplementation :: ClassModule -> String+genImportInImplementation :: ClassModule -> [ImportDecl] genImportInImplementation m =    let modlstraw' = cmImportedModulesForFFI m       modlsthigh = nub $ map getClassModuleBase $ concatMap class_allparents (cmClass m)       modlstraw = filter (not.(flip elem modlsthigh)) modlstraw' -      getImportOneClassRaw mname = -        intercalateWith connRet (importOneClass mname) -                        ["RawType","Cast","Interface"]-      getImportOneClassHigh mname = -        intercalateWith connRet (importOneClass mname) -                        ["RawType","Cast","Interface"] -  in  importOneClass (cmModule m) "RawType"-      `connRet`-      importOneClass (cmModule m) "FFI"-      `connRet`-      importOneClass (cmModule m) "Interface"-      `connRet`-      importOneClass (cmModule m) "Cast"-      `connRet`-      intercalateWith connRet getImportOneClassRaw modlstraw-      `connRet` -      intercalateWith connRet getImportOneClassHigh modlsthigh+  in  [ mkImport (cmModule m <.> "RawType")+      , mkImport (cmModule m <.> "FFI")+      , mkImport (cmModule m <.> "Interface")+      , mkImport (cmModule m <.> "Cast") ]+      <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlstraw+      <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlsthigh --- | -genImportInExistential :: DaughterMap -> ClassModule -> String-genImportInExistential dmap m = -  let daughters = concat . catMaybes $ (map (flip M.lookup dmap . getClassModuleBase)  (cmClass m))-      alldaughters' = nub . map getClassModuleBase $ daughters-      -- alldaughters = filter ((&&) <$> (/= "TClass") <*> (/= "TObject")) alldaughters'-      alldaughters = alldaughters'-      getImportOneClass mname = -          intercalateWith connRet (importOneClass mname) -                          ["RawType", "Cast", "Interface", "Implementation"]-  in  intercalateWith connRet getImportOneClass alldaughters+        +genTmplInterface :: TemplateClass -> [Decl]+genTmplInterface t =+  [ mkData rname [mkTBind tp] [] []+  , mkNewtype hname [mkTBind tp]+      [ QualConDecl noLoc [] [] (conDecl hname [TyApp tyPtr rawtype]) ] []+  , mkClass [] (typeclassNameT t) [mkTBind tp] methods+  , mkInstance [] "FPtr" [ hightype ] fptrbody+  , mkInstance [] "Castable" [ hightype, TyApp tyPtr rawtype ] castBody+  ]+ where (hname,rname) = hsTemplateClassName t+       tp = tclass_param t+       fs = tclass_funcs t+       rawtype = TyApp (tycon rname) (mkTVar tp)+       hightype = TyApp (tycon hname) (mkTVar tp)+       sigdecl f@TFun {..}    = mkFunSig tfun_name (functionSignatureT t f)+       sigdecl f@TFunNew {..} = mkFunSig ("new"<>tclass_name t) (functionSignatureT t f)+       sigdecl f@TFunDelete = mkFunSig ("delete"<>tclass_name t) (functionSignatureT t f)+       methods = map (ClsDecl . sigdecl) fs+       fptrbody = [ InsType noLoc (TyApp (tycon "Raw") hightype) rawtype+                  , InsDecl (mkBind1 "get_fptr" [PApp (unqual hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)+                  , InsDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing)+                  ]  +genTmplImplementation :: TemplateClass -> [Decl]+genTmplImplementation t = concatMap gen (tclass_funcs t)+  where+    gen f = mkFun nh sig [p "nty", p "ncty"] rhs (Just binds)+      where nh = case f of+                   TFun {..}    -> "t_" <> tfun_name+                   TFunNew {..} -> "t_" <> "new" <> tclass_name t+                   TFunDelete   -> "t_" <> "delete" <> tclass_name t                   +            nc = case f of+                   TFun {..}    -> tfun_name+                   TFunNew {..} -> "new"+                   TFunDelete   -> "delete"                   +            sig = tycon "Name" `TyFun` (tycon "String" `TyFun` tycon "ExpQ")+            v = mkVar+            p = mkPVar+            tp = tclass_param t+            prefix = tclass_name t+            lit = Lit (String (prefix<>"_"<>nc<>"_"))+            lam = Lambda noLoc [p "n"] ( lit `App` v "<>" `App` v "n") +            rhs = App (v "mkTFunc") (Tuple Boxed [v "nty", v "ncty", lam, v "tyf"])+            sig' = functionSignatureTT t f+            binds = BDecls [ mkBind1 "tyf" [mkPVar "n"]+                               (Let (BDecls [ pbind (p tp) (v "return" `App` (con "ConT" `App` v "n")) Nothing ])+                                 (BracketExp (TypeBracket sig')))+                               Nothing +                           ]  ---------------------------- Top Level Function -----------------------------genTopLevelFuncDef :: TopLevelFunction -> String -genTopLevelFuncDef f@TopLevelFunction {..} = -    let fname = hsFrontNameForTopLevelFunction f-        cfname = "c_" ++ toLowers fname -        args = toplevelfunc_args-        ret = toplevelfunc_ret -        xformerstr = let len = length args in if len > 0 then "xform" ++ show (len-1) else "xformnull"-        prefixstr =  -          let prefixlst = (snd . mkHsFuncArgType) toplevelfunc_args-                        ++ (snd . mkHsFuncRetType) toplevelfunc_ret-          in  if null prefixlst-              then "" -              else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => "  +genTmplInstance :: TemplateClass -> [TemplateFunction] -> [Decl]+genTmplInstance t fs = mkFun fname sig [p "n", p "ctyp"] rhs Nothing+  where tname = tclass_name t +        fname = "gen" <> tname <> "InstanceFor"+        p = mkPVar+        v = mkVar+        l = Lit . String+        sig = tycon "Name" `TyFun` (tycon "String" `TyFun` (TyApp (tycon "Q") (TyList (tycon "Dec")))) -        argstr = intercalateWith connArrow id $-                      (fst . mkHsFuncArgType) toplevelfunc_args -                      ++ ["IO " ++ (fst . mkHsFuncRetType) toplevelfunc_ret]  -        defstr = fname ++ " = " ++ xformerstr ++ " " ++ cfname-    in fname ++ " :: " ++ prefixstr ++ argstr ++ "\n" ++ defstr -genTopLevelFuncDef v@TopLevelVariable {..} = -    let fname = hsFrontNameForTopLevelFunction v-        cfname = "c_" ++ toLowers fname -        args = []-        ret = toplevelvar_ret -        xformerstr = let len = length args in if len > 0 then "xform" ++ show (len-1) else "xformnull"-        prefixstr =  -          let prefixlst = (snd . mkHsFuncRetType) toplevelvar_ret-          in  if null prefixlst-              then "" -              else "(" ++ (intercalateWith conncomma id prefixlst) ++ ") => "  +        nfs = zip ([1..] :: [Int]) fs+        rhs = Do (map genstmt nfs <> [LetStmt (lststmt nfs), Qualifier retstmt]) -        argstr = intercalateWith connArrow id $ ["IO " ++ (fst . mkHsFuncRetType) toplevelvar_ret]  -        defstr = fname ++ " = " ++ xformerstr ++ " " ++ cfname-    in fname ++ " :: " ++ prefixstr ++ argstr ++ "\n" ++ defstr +        genstmt (n,TFun    {..}) = Generator noLoc (p ("f"<>show n))+                                   (v "mkMember" `App` l tfun_name+                                                 `App` v ("t_" <> tfun_name)+                                                 `App` v "n"+                                                 `App` v "ctyp"+                                   )+        genstmt (n,TFunNew {..}) = Generator noLoc (p ("f"<>show n)) +                                   (v "mkNew"    `App` l ("new" <> tname)+                                                 `App` v ("t_new" <> tname)+                                                 `App` v "n"+                                                 `App` v "ctyp"+                                   )+        genstmt (n,TFunDelete)   = Generator noLoc (p ("f"<>show n)) +                                   (v "mkDelete" `App` l ("delete"<>tname)+                                                 `App` v ("t_delete" <> tname)+                                                 `App` v "n"+                                                 `App` v "ctyp"+                                   )                                   +        lststmt lst = BDecls [ pbind (p "lst") (List (map (v . (\n -> "f" <> show n) . fst) lst)) Nothing ]+        retstmt = v "return"+                  `App` List [ v "mkInstance"+                               `App` List []+                               `App` (con "AppT"+                                      `App` (v "con" `App` l (typeclassNameT t))+                                      `App` (con "ConT" `App` (v "n"))+                                     )+                               `App` (v "lst")+                             ]
lib/FFICXX/Generate/Code/MethodDef.hs view
@@ -1,7 +1,10 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Code.MethodDef--- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,24 +15,56 @@  module FFICXX.Generate.Code.MethodDef where -import FFICXX.Generate.Type.Class-import FFICXX.Generate.Util +import           Data.Monoid                ( (<>) )+--+import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Util   +returnCpp :: Bool  -- ^ for simple type+          -> Types+          -> String -- ^ call string+          -> String+returnCpp b ret callstr = +  case ret of          +    Void                    -> callstr <> ";"+    SelfType                -> "return to_nonconst<Type ## _t, Type>((Type *)"+                                <> callstr <> ") ;"+    CT (CRef _) _           -> "return ((*)"<>callstr<>");"+    CT _ _                  -> "return "<>callstr<>";" +    CPT (CPTClass c') _     -> "return to_nonconst<"<>str<>"_t,"<>str+                               <>">(("<>str<>"*)"<>callstr<>");"+                               where str = class_name c'+    CPT (CPTClassRef _c') _ -> "return ((*)"<>callstr<>");"+    CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str+                               <>">(new "<>str<>"("<>callstr<>"));"+                               where str = class_name c'++    TemplateApp _ _ _       -> "return (" <> callstr <> ");"          +    TemplateType _          -> error "returnCpp: TemplateType"+    TemplateParam _         ->+      if b then "return (" <> callstr <> ");"+           else "return to_nonconst<Type ## _t, Type>((Type *)&("+                <> callstr <> ")) ;"+++ -- Function Declaration and Definition  funcToDecl :: Class -> Function -> String  funcToDecl c func    | isNewFunc func || isStaticFunc func = -    let tmpl = "$returntype$ Type ## _$funcname$ ( $args$ )" -    in  render tmpl [ ("returntype", rettypeToString (genericFuncRet func))  -                    , ("funcname",  aliasedFuncName c func) -                    , ("args", argsToStringNoSelf (genericFuncArgs func)) ] +    let tmpl = "$returntype Type ## _$funcname ( $args )" +    in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func))  +                           , ("funcname",  aliasedFuncName c func) +                           , ("args", argsToStringNoSelf (genericFuncArgs func))+                           ])   | otherwise =  -    let tmpl = "$returntype$ Type ## _$funcname$ ( $args$ )" -    in  render tmpl [ ("returntype", rettypeToString (genericFuncRet func))  -                    , ("funcname", aliasedFuncName c func) -                    , ("args", argsToString (genericFuncArgs func)) ] +    let tmpl = "$returntype Type ## _$funcname ( $args )" +    in subst tmpl (context [ ("returntype", rettypeToString (genericFuncRet func))  +                           , ("funcname", aliasedFuncName c func) +                           , ("args", argsToString (genericFuncArgs func))+                           ])    @@ -41,8 +76,8 @@ funcToDef c func    | isNewFunc func =      let declstr = funcToDecl c func-        callstr = "(" ++ argsToCallString (genericFuncArgs func) ++ ")"-        returnstr = "Type * newp = new Type " ++ callstr ++ "; \\\nreturn to_nonconst<Type ## _t, Type >(newp);"+        callstr = "(" <> argsToCallString (genericFuncArgs func) <> ")"+        returnstr = "Type * newp = new Type " <> callstr <> "; \\\nreturn to_nonconst<Type ## _t, Type >(newp);"     in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"]    | isDeleteFunc func =      let declstr = funcToDecl c func@@ -50,33 +85,18 @@     in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"]    | isStaticFunc func =      let declstr = funcToDecl c func-        callstr = cppFuncName c func ++ "("-                  ++ argsToCallString (genericFuncArgs func)   -                  ++ ")"-        returnstr = case (genericFuncRet func) of          -          Void -> callstr ++ ";"-          SelfType -> "return to_nonconst<Type ## _t, Type>((Type *)" ++ callstr ++ ") ;"-          (CT _ctyp _isconst) -> "return "++callstr++";" -          (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str-                                    ++">(("++str++"*)"++callstr++");" -            where str = class_name c' -          (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" -    in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"] +        callstr = cppFuncName c func <> "("+                  <> argsToCallString (genericFuncArgs func)   +                  <> ")"+        returnstr = returnCpp False (genericFuncRet func) callstr+    in intercalateWith connBSlash id [declstr, "{", returnstr, "}"]    | otherwise =      let declstr = funcToDecl c func-        callstr = -- "to_nonconst<Type,Type ## _t>(p)->" -                  "TYPECASTMETHOD(Type,"++ aliasedFuncName c func ++ "," ++ class_name c ++ ")(p)->"-                  ++ cppFuncName c func ++ "("-                  ++ argsToCallString (genericFuncArgs func)   -                  ++ ")"-        returnstr = case (genericFuncRet func) of          -          Void -> callstr ++ ";"-          SelfType -> "return to_nonconst<Type ## _t, Type>((Type *)" ++ callstr ++ ") ;"-          (CT _ctyp _isconst) -> "return "++callstr++";" -          (CPT (CPTClass c') _) -> "return to_nonconst<"++str++"_t,"++str-                                    ++">(("++str++"*)"++callstr++");"-             where str = class_name c'-          (CPT (CPTClassRef _c') _) -> "return ((*)"++callstr++");" +        callstr = "TYPECASTMETHOD(Type,"<> aliasedFuncName c func <> "," <> class_name c <> ")(p)->"+                  <> cppFuncName c func <> "("+                  <> argsToCallString (genericFuncArgs func)   +                  <> ")"+        returnstr = returnCpp False (genericFuncRet func) callstr     in  intercalateWith connBSlash id [declstr, "{", returnstr, "}"]   @@ -85,6 +105,49 @@ funcsToDefs c = intercalateWith connBSlash (funcToDef c)  +tmplFunToDecl :: Bool -> TemplateClass -> TemplateFunction -> String +tmplFunToDecl b t@TmplCls {..} TFun {..} =  +  subst "$ret ${tname}_${fname}_ ## Type ( $args )"+    (context [ ("tname", tclass_name                     )  +             , ("fname", tfun_name                       ) +             , ("args" , tmplAllArgsToString Self t tfun_args )+             , ("ret"  , tmplRetTypeToString b tfun_ret    ) ]) +tmplFunToDecl b t@TmplCls {..} TFunNew {..} =  +  subst "$ret ${tname}_new_ ## Type ( $args )"+    (context [ ("tname", tclass_name                     )  +             , ("args" , tmplAllArgsToString NoSelf t tfun_new_args )+             , ("ret"  , tmplRetTypeToString b (TemplateType t)) ]) +tmplFunToDecl _ t@TmplCls {..} TFunDelete =  +  subst "$ret ${tname}_delete_ ## Type ( $args )"+    (context [ ("tname", tclass_name                     )  +             , ("args" , tmplAllArgsToString Self t [] )+             , ("ret"  , "void" ) ]) ++++tmplFunToDef :: Bool -- ^ for simple type+             -> TemplateClass+             -> TemplateFunction+             -> String+tmplFunToDef b t@TmplCls {..} f = intercalateWith connBSlash id [declstr, "  {", "    "<>returnstr, "  }"]+ where+  declstr = tmplFunToDecl b t f+  callstr =+    case f of+      TFun {..}    -> "(reinterpret_cast<" <> tclass_oname <> "<Type>*>(p))->"+                      <> tfun_oname <> "("+                      <> tmplAllArgsToCallString tfun_args   +                      <> ")"+      TFunNew {..} -> "new " <> tclass_oname <> "<Type>("+                      <> tmplAllArgsToCallString tfun_new_args+                      <> ")"+      TFunDelete   -> "delete (reinterpret_cast<" <> tclass_oname <> "<Type>*>(p))"+                      +  returnstr =+    case f of+      TFunNew {..} -> "return reinterpret_cast<void*>("<>callstr<>");"+      TFunDelete   -> callstr <> ";"+      TFun {..} -> returnCpp b (tfun_ret) callstr
+ lib/FFICXX/Generate/ContentMaker.hs view
@@ -0,0 +1,427 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-----------------------------------------------------------------------------+-- |+-- Module      : FFICXX.Generate.ContentMaker+-- Copyright   : (c) 2011-2017 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------++module FFICXX.Generate.ContentMaker where ++import           Control.Lens                           ( set,at )+import           Control.Monad.Trans.Reader+import           Data.Function                          ( on )+import qualified Data.Map                          as M+import           Data.Monoid                            ( (<>) )+import           Data.List +import           Data.List.Split                        ( splitOn ) +import           Data.Maybe+import           Data.Text                              ( Text )+import           Language.Haskell.Exts.Syntax           ( Module(..), Decl(..) )+import           Language.Haskell.Exts.Pretty           ( prettyPrint )+import           System.FilePath+-- +import           FFICXX.Generate.Code.Cpp+import           FFICXX.Generate.Code.HsFFI +import           FFICXX.Generate.Code.HsFrontEnd+import           FFICXX.Generate.Type.Annotate+import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.Module+import           FFICXX.Generate.Type.PackageInterface  ( TypeMacro(..), HeaderName(..)+                                                        , PackageInterface, PackageName(..)+                                                        , ClassName(..)+                                                        )+import           FFICXX.Generate.Util+import           FFICXX.Generate.Util.HaskellSrcExts+--++srcDir :: FilePath -> FilePath+srcDir installbasedir = installbasedir </> "src" ++csrcDir :: FilePath -> FilePath+csrcDir installbasedir = installbasedir </> "csrc" ++---- common function for daughter++-- | +mkGlobal :: [Class] -> ClassGlobal+mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap +++-- | +buildDaughterDef :: ((String,[Class]) -> String) +              -> DaughterMap +              -> String +buildDaughterDef f m =   +    let lst = M.toList m +        f' (x,xs) =  f (x,filter (not.isAbstractClass) xs) +    in (concatMap f' lst)++-- | +buildParentDef :: ((Class,Class)->String) -> Class -> String+buildParentDef f cls = g (class_allparents cls,cls)+  where g (ps,c) = concatMap (\p -> f (p,c)) ps++-- | +mkProtectedFunctionList :: Class -> String +mkProtectedFunctionList c = +    (unlines +     . map (\x->"#define IS_" <> class_name c <> "_" <> x <> "_PROTECTED ()") +     . unProtected . class_protected) c ++-- |+buildTypeDeclHeader :: TypeMacro -- ^ typemacro +                 -> [Class]+                 -> String +buildTypeDeclHeader (TypMcro typemacro) classes =+  let typeDeclBodyStr   = genAllCppHeaderTmplType classes +  in subst+       "#ifdef __cplusplus\n\+       \extern \"C\" { \n\+       \#endif\n\+       \\n\+       \#ifndef $typemacro\n\+       \#define $typemacro\n\+       \\n\+       \$typeDeclBody\n\+       \\n\+       \#endif // $typemacro\n\+       \\n\+       \#ifdef __cplusplus\n\+       \}\n\+       \#endif\n" +       (context [ ("typeDeclBody", typeDeclBodyStr ) +                , ("typemacro"   , typemacro       ) ])++++declarationTemplate :: Text+declarationTemplate = +  "#ifdef __cplusplus\n\+  \extern \"C\" { \n\+  \#endif\n\+  \\n\+  \#ifndef $typemacro\n\+  \#define $typemacro\n\+  \\n\+  \#include \"${cprefix}Type.h\"\+  \\n\+  \$declarationheader\n\+  \\n\+  \$declarationbody\n\+  \\n\+  \#endif // $typemacro\n\+  \\n\+  \#ifdef __cplusplus\n\+  \}\n\+  \#endif\n"++-- | +buildDeclHeader :: TypeMacro  -- ^ typemacro prefix +             -> String     -- ^ C prefix +             -> ClassImportHeader +             -> String +buildDeclHeader (TypMcro typemacroprefix) cprefix header =+  let classes = [cihClass header]+      aclass = cihClass header+      typemacrostr = typemacroprefix <> class_name aclass <> "__" +      declHeaderStr = intercalateWith connRet (\x->"#include \""<>x<>"\"") $+                        map unHdrName (cihIncludedHPkgHeadersInH header)+      declDefStr    = genAllCppHeaderTmplVirtual classes +                      `connRet2`+                      genAllCppHeaderTmplNonVirtual classes +                      `connRet2`   +                      genAllCppDefTmplVirtual classes+                      `connRet2`+                      genAllCppDefTmplNonVirtual classes+      classDeclsStr = if (fst.hsClassName) aclass /= "Deletable"+                        then buildParentDef genCppHeaderInstVirtual aclass +                             `connRet2`+                             genCppHeaderInstVirtual (aclass, aclass)+                             `connRet2` +                             genAllCppHeaderInstNonVirtual classes+                        else "" +      declBodyStr   = declDefStr +                      `connRet2` +                      classDeclsStr +  in subst declarationTemplate+       (context [ ("typemacro"        , typemacrostr  )+                , ("cprefix"          , cprefix       )+                , ("declarationheader", declHeaderStr ) +                , ("declarationbody"  , declBodyStr   ) ])+++definitionTemplate :: Text+definitionTemplate =+  "#include <MacroPatternMatch.h>\n\+  \$header\n\+  \\n\+  \$namespace\n\+  \\n\+  \#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)\n\+  \\n\+  \#define TYPECASTMETHOD(cname,mname,oname) \\\n\+  \  IIF( CHECKPROTECT(cname,mname) ) ( \\\n\+  \  (to_nonconst<oname,cname ## _t>), \\\n\+  \  (to_nonconst<cname,cname ## _t>) )\n\+  \\n\+  \$cppbody\n"+++-- | +buildDefMain :: ClassImportHeader +          -> String +buildDefMain header =+  let classes = [cihClass header]+      headerStr = genAllCppHeaderInclude header <> "\n#include \"" <> (unHdrName (cihSelfHeader header)) <> "\"" +      namespaceStr = (concatMap (\x->"using namespace " <> unNamespace x <> ";\n") . cihNamespace) header+      aclass = cihClass header+      cppBody = mkProtectedFunctionList (cihClass header) +                `connRet`+                buildParentDef genCppDefInstVirtual (cihClass header)+                `connRet` +                if isAbstractClass aclass +                  then "" +                  else genCppDefInstVirtual (aclass, aclass)+                `connRet`+                genAllCppDefInstNonVirtual classes+  in subst definitionTemplate (context ([ ("header"   , headerStr    )+                                        , ("namespace", namespaceStr )+                                        , ("cppbody"  , cppBody      ) ])) ++-- | +buildTopLevelFunctionHeader :: TypeMacro  -- ^ typemacro prefix +                         -> String     -- ^ C prefix +                         -> TopLevelImportHeader+                         -> String +buildTopLevelFunctionHeader (TypMcro typemacroprefix) cprefix tih =+  let typemacrostr = typemacroprefix <> "TOPLEVEL" <> "__" +      declHeaderStr = intercalateWith connRet (\x->"#include \""<>x<>"\"")+                      . map (unHdrName . cihSelfHeader) . tihClassDep $ tih+      declBodyStr    = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih)+  in subst declarationTemplate (context [ ("typemacro"        , typemacrostr  )+                                        , ("cprefix"          , cprefix       )+                                        , ("declarationheader", declHeaderStr )+                                        , ("declarationbody"  , declBodyStr   ) ])++-- | +buildTopLevelFunctionCppDef :: TopLevelImportHeader -> String +buildTopLevelFunctionCppDef tih =+  let cihs = tihClassDep tih+      declHeaderStr = "#include \"" <> tihHeaderFileName tih <.> "h" <> "\""+                      `connRet2`+                      (intercalate "\n" (nub (map genAllCppHeaderInclude cihs)))+                      `connRet2`+                      ((intercalateWith connRet (\x->"#include \""<>x<>"\"") . map (unHdrName . cihSelfHeader)) cihs)+      allns = nubBy ((==) `on` unNamespace) (tihClassDep tih >>= cihNamespace)+      namespaceStr = do ns <- allns +                        ("using namespace " <> unNamespace ns <> ";\n")+      declBodyStr    = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih)++  in subst definitionTemplate (context [ ("header"   , declHeaderStr)+                                       , ("namespace", namespaceStr )+                                       , ("cppbody"  , declBodyStr  ) ])++-- | +buildTemplateHeader :: TypeMacro  -- ^ typemacro prefix +                 -- -> String     -- ^ C prefix+                 -> TemplateClass+                 -> String +buildTemplateHeader (TypMcro typemacroprefix) t =+  let typemacrostr = typemacroprefix <> "TEMPLATE" <> "__"+      fs = tclass_funcs t+      deffunc = intercalateWith connRet (genTmplFunCpp False t) fs+                ++ "\n\n"+                ++ intercalateWith connRet (genTmplFunCpp True t) fs+      classlevel = genTmplClassCpp False t fs ++ "\n\n" ++ genTmplClassCpp True t fs+  in subst+       "#ifndef $typemacro\n\+       \#define $typemacro\n\+       \\n\+       \$deffunc\n\+       \$classlevel\n\+       \#endif\n"+       (context [ ("typemacro", typemacrostr )+                , ("deffunc"  , deffunc      )+                , ("classlevel" , classlevel )+                ])+++-- | +buildFFIHsc :: ClassModule -> Module+buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody +  where mname = cmModule m+        headers = cmCIH m+        ffiImports = [ mkImport "Foreign.C", mkImport "Foreign.Ptr", mkImport (mname <.> "RawType") ]+                     <> genImportInFFI m+                     <> genExtraImport m+        hscBody = concatMap genHsFFI headers+++-- |                      +buildRawTypeHs :: ClassModule -> Module+buildRawTypeHs m = mkModule (cmModule m <.> "RawType")+                  [lang [ "ForeignFunctionInterface", "TypeFamilies", "MultiParamTypeClasses"+                        , "FlexibleInstances", "TypeSynonymInstances"+                        , "EmptyDataDecls", "ExistentialQuantification", "ScopedTypeVariables" ]]+                  rawtypeImports rawtypeBody+  where rawtypeImports = [ {- mkImport "Foreign.ForeignPtr", -}+                           mkImport "Foreign.Ptr"+                         , mkImport "FFICXX.Runtime.Cast"+                         ] +        rawtypeBody = concatMap hsClassRawType . filter (not.isAbstractClass) . cmClass $ m++-- | +buildInterfaceHs :: AnnotateMap -> ClassModule -> Module   +buildInterfaceHs amap m = mkModule (cmModule m <.> "Interface")+                            [lang [ "EmptyDataDecls", "ExistentialQuantification"+                                  , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface"+                                  , "MultiParamTypeClasses"+                                  , "ScopedTypeVariables"                                 +                                  , "TypeFamilies", "TypeSynonymInstances"+                                  ]]+                            ifaceImports ifaceBody+  where classes = cmClass m+        ifaceImports = [ mkImport "Data.Word"+                       , mkImport "Foreign.C"+                       , mkImport "Foreign.Ptr"+                       , mkImport "FFICXX.Runtime.Cast" ]+                       <> genImportInInterface m+                       <> genExtraImport m+        ifaceBody = +          runReader (mapM genHsFrontDecl classes) amap +          <> (concatMap genHsFrontUpcastClass . filter (not.isAbstractClass)) classes+          <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes++-- | +buildCastHs :: ClassModule -> Module+buildCastHs m = mkModule (cmModule m <.> "Cast")+               [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies"+                      , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ]+               castImports body+  where classes = cmClass m+        castImports = [ mkImport "Foreign.Ptr"+                      , mkImport "FFICXX.Runtime.Cast"+                      , mkImport "System.IO.Unsafe" ]+                      <> genImportInCast m+        body = mapMaybe genHsFrontInstCastable classes+               <> mapMaybe genHsFrontInstCastableSelf classes++-- | +buildImplementationHs :: AnnotateMap -> ClassModule -> Module+buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation")+                                 [ lang [ "EmptyDataDecls"+                                        , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface"+                                        , "IncoherentInstances"                                                                                +                                        , "MultiParamTypeClasses"+                                        , "OverlappingInstances"+                                        , "TypeFamilies", "TypeSynonymInstances"+                                        ] ]+                                 implImports implBody+  where classes = cmClass m+        implImports = [ mkImport "FFICXX.Runtime.Cast"+                      , mkImport "Data.Word"+                      , mkImport "Foreign.C"+                      , mkImport "Foreign.Ptr"+                      , mkImport "System.IO.Unsafe" ]+                      <> 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++buildTemplateHs :: TemplateClassModule -> Module+buildTemplateHs m = mkModule (tcmModule m <.> "Template")+                   [lang  [ "EmptyDataDecls", "FlexibleInstances", "MultiParamTypeClasses"+                          , "TypeFamilies"] ]+                   [ mkImport "Foreign.C.Types"+                   , mkImport "Foreign.Ptr"+                   , mkImport "FFICXX.Runtime.Cast"+                   ]+                   body+  where ts = tcmTemplateClasses m+        body = concatMap genTmplInterface ts ++buildTHHs :: TemplateClassModule -> Module+buildTHHs m = mkModule (tcmModule m <.> "TH")+             [lang  ["TemplateHaskell"] ]+             ([ mkImport "Data.Char"+              , mkImport "Data.Monoid"+              , mkImport "Foreign.C.Types"+              , mkImport "Foreign.Ptr"+              , mkImport "Language.Haskell.TH"+              , mkImport "Language.Haskell.TH.Syntax"+              , mkImport "FFICXX.Runtime.TH"+              ] <> imports)+             body+  where ts = tcmTemplateClasses m+        imports = [ mkImport (tcmModule m <.> "Template") ]+        body = concatMap genTmplImplementation ts+               <> concatMap (\t -> genTmplInstance t (tclass_funcs t)) ts++-- | +buildInterfaceHSBOOT :: String -> Module+buildInterfaceHSBOOT mname = mkModule (mname <.> "Interface") [] [] hsbootBody+  where cname = last (splitOn "." mname)+        hsbootBody = [ mkClass [] ('I':cname) [mkTBind "a"] [] ]++-- | +buildModuleHs :: ClassModule -> Module+buildModuleHs m = mkModuleE (cmModule m) [] (concatMap genExport (cmClass m)) (genImportInModule (cmClass m)) []++-- | +buildPkgHs :: String -> [ClassModule] -> TopLevelImportHeader -> String +buildPkgHs modname mods tih = +    let tfns = tihFuncs tih +        exportListStr = intercalateWith (conn "\n, ") ((\x->"module " <> x).cmModule) mods +                        <> if null tfns +                           then "" +                           else "\n, " <> intercalateWith (conn "\n, ") hsFrontNameForTopLevelFunction tfns +        importListStr = intercalateWith connRet ((\x->"import " <> x).cmModule) mods+                        <> if null tfns +                           then "" +                           else "" `connRet2` "import Foreign.C" `connRet` "import Foreign.Ptr"+                                `connRet` "import FFICXX.Runtime.Cast" +                                `connRet`+                                intercalateWith connRet +                                  ((\x->"import " <> modname <> "." <> x <> ".RawType")+                                   .fst.hsClassName.cihClass) (tihClassDep tih)+        topLevelDefStr = intercalate "\n" (map (prettyPrint . genTopLevelFuncFFI tih) tfns)+                         `connRet2`+                         intercalate "\n\n" (map (intercalateWith connRet prettyPrint) (map genTopLevelFuncDef tfns))+    in subst+         "module $summarymod (\n\+         \  $exportList\n\+         \) where\n\+         \\n\+         \$importList\n\+         \$topLevelDef\n"+         (context [ ("summarymod" , modname       )+                  , ("exportList" , exportListStr ) +                  , ("importList" , importListStr ) +                  , ("topLevelDef", topLevelDefStr) ])+++  +-- |+buildPackageInterface :: PackageInterface +                      -> PackageName +                      -> [ClassImportHeader] +                      -> PackageInterface+buildPackageInterface pinfc pkgname = foldr f pinfc +  where f cih repo = +          let name = (class_name . cihClass) cih +              header = cihSelfHeader cih +          in set (at (pkgname,ClsName name)) (Just header) repo+
− lib/FFICXX/Generate/Generator/ContentMaker.hs 
@@ -1,493 +0,0 @@-{-# LANGUAGE GADTs #-}---------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Generator.ContentMaker--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim------ License     : BSD3--- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Generator.ContentMaker where --import           Control.Applicative-import           Control.Lens (set,at)-import           Control.Monad.Trans.Reader-import           Data.Function (on)-import qualified Data.Map as M-import           Data.List -import           Data.List.Split (splitOn) -import           Data.Maybe-import           System.FilePath -import           Text.StringTemplate hiding (render)--- -import           FFICXX.Generate.Code.Cpp-import           FFICXX.Generate.Code.HsFFI -import           FFICXX.Generate.Code.HsFrontEnd-import           FFICXX.Generate.Type.Annotate-import           FFICXX.Generate.Type.Class-import qualified FFICXX.Generate.Type.PackageInterface as T-import           FFICXX.Generate.Util-----srcDir :: FilePath -> FilePath-srcDir installbasedir = installbasedir </> "src" --csrcDir :: FilePath -> FilePath-csrcDir installbasedir = installbasedir </> "csrc" --pkgModuleTemplate :: String-pkgModuleTemplate = "Pkg.hs"--moduleTemplate :: String -moduleTemplate = "module.hs"--hsbootTemplate :: String-hsbootTemplate = "Class.hs-boot"---- cabalTemplate :: String --- cabalTemplate = "Pkg.cabal"--declarationTemplate :: String-declarationTemplate = "Module.h"--typeDeclHeaderFileName :: String-typeDeclHeaderFileName = "PkgType.h"--declbodyTemplate :: String-declbodyTemplate    = "declbody.h"--funcdeclTemplate :: String-funcdeclTemplate    = "funcdecl.h" --definitionTemplate :: String-definitionTemplate = "Pkg.cpp"--classDefTemplate :: String-classDefTemplate   = "classdef.cpp"--functionTemplate :: String-functionTemplate   = "function.cpp" --funcbodyTemplate :: String-funcbodyTemplate   = "functionbody.cpp"--headerFileName :: String-headerFileName = "Module.h"--cppFileName :: String-cppFileName = "Pkg.cpp" --hscFileName :: String-hscFileName = "FFI.hsc"--hsFileName :: String-hsFileName  = "Implementation.hs"--typeHsFileName :: String-typeHsFileName = "Interface.hs"--existHsFileName :: String -existHsFileName = "Existential.hs"--rawtypeHsFileName :: String-rawtypeHsFileName = "RawType.hs"--ffiHscFileName :: String -ffiHscFileName = "FFI.hsc"--interfaceHsFileName :: String-interfaceHsFileName = "Interface.hs"--castHsFileName :: String-castHsFileName = "Cast.hs"--implementationHsFileName :: String -implementationHsFileName = "Implementation.hs"--existentialHsFileName :: String -existentialHsFileName = "Existential.hs"------- common function for daughter----- | -mkGlobal :: [Class] -> ClassGlobal-mkGlobal = ClassGlobal <$> mkDaughterSelfMap <*> mkDaughterMap ----- | -mkDaughterDef :: ((String,[Class]) -> String) -              -> DaughterMap -              -> String -mkDaughterDef f m =   -    let lst = M.toList m -        f' (x,xs) =  f (x,filter (not.isAbstractClass) xs) -    in (concatMap f' lst)---- | -mkParentDef :: ((Class,Class)->String) -> Class -> String-mkParentDef f cls = g (class_allparents cls,cls)-  where g (ps,c) = concatMap (\p -> f (p,c)) ps----- | -mkProtectedFunctionList :: Class -> String -mkProtectedFunctionList c = -    (unlines -     . map (\x->"#define IS_" ++ class_name c ++ "_" ++ x ++ "_PROTECTED ()") -     . unProtected . class_protected) c ------- |-mkTypeDeclHeader :: STGroup String -- -> ClassGlobal -                 -> T.TypeMacro -- ^ typemacro -                 -> [Class]-                 -> String -mkTypeDeclHeader templates (T.TypMcro typemacro) classes =-  let typeDeclBodyStr   = genAllCppHeaderTmplType classes -  in  renderTemplateGroup -        templates -        [ ("typeDeclBody", typeDeclBodyStr ) -        , ("typemacro", typemacro ) --        ] -        typeDeclHeaderFileName---- | -mkDeclHeader :: STGroup String -             -- -> ClassGlobal -             -> T.TypeMacro  -- ^ typemacro prefix -             -> String     -- ^ C prefix -             -> ClassImportHeader -             -> String -mkDeclHeader templates (T.TypMcro typemacroprefix) cprefix header =-  let classes = [cihClass header]-      aclass = cihClass header-      typemacrostr = typemacroprefix ++ class_name aclass ++ "__" -      declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"") $-                        map T.unHdrName (cihIncludedHPkgHeadersInH header)-      declDefStr    = genAllCppHeaderTmplVirtual classes -                      `connRet2`-                      genAllCppHeaderTmplNonVirtual classes -                      `connRet2`   -                      genAllCppDefTmplVirtual classes-                      `connRet2`-                       genAllCppDefTmplNonVirtual classes-      -- dsmap         = cgDaughterSelfMap cglobal-      classDeclsStr = if (fst.hsClassName) aclass /= "Deletable"-                        then mkParentDef genCppHeaderInstVirtual aclass -                             `connRet2`-                             genCppHeaderInstVirtual (aclass, aclass)-                             `connRet2` -                             genAllCppHeaderInstNonVirtual classes-                        else "" -      declBodyStr   = declDefStr -                      `connRet2` -                      classDeclsStr -  in  renderTemplateGroup -        templates -        [ ("typemacro", typemacrostr)-        , ("cprefix", cprefix)-        , ("declarationheader", declHeaderStr ) -        , ("declarationbody", declBodyStr ) ] -        declarationTemplate---- | -mkDefMain :: STGroup String -          -> ClassImportHeader -          -> String -mkDefMain templates header =-  let classes = [cihClass header]-      headerStr = genAllCppHeaderInclude header ++ "\n#include \"" ++ (T.unHdrName (cihSelfHeader header)) ++ "\"" -      namespaceStr = (concatMap (\x->"using namespace " ++ unNamespace x ++ ";\n") . cihNamespace) header-      aclass = cihClass header-      cppBody = mkProtectedFunctionList (cihClass header) -                `connRet`-                mkParentDef genCppDefInstVirtual (cihClass header)-                `connRet` -                if isAbstractClass aclass -                  then "" -                  else genCppDefInstVirtual (aclass, aclass)-                `connRet`-                genAllCppDefInstNonVirtual classes-  in  renderTemplateGroup -        templates -        [ ("header" , headerStr ) -        , ("namespace", namespaceStr ) -        , ("cppbody", cppBody )  -        ] -        definitionTemplate----- | -mkTopLevelFunctionHeader :: STGroup String -                         -> T.TypeMacro  -- ^ typemacro prefix -                         -> String     -- ^ C prefix -                         -> TopLevelImportHeader-                         -> String -mkTopLevelFunctionHeader templates (T.TypMcro typemacroprefix) cprefix tih =-  let typemacrostr = typemacroprefix ++ "TOPLEVEL" ++ "__" -      declHeaderStr = intercalateWith connRet (\x->"#include \""++x++"\"")-                      . map (T.unHdrName . cihSelfHeader) . tihClassDep $ tih-      declBodyStr    = intercalateWith connRet genTopLevelFuncCppHeader (tihFuncs tih)-  in  renderTemplateGroup -        templates -        [ ("typemacro", typemacrostr)-        , ("cprefix", cprefix)-        , ("declarationheader", declHeaderStr ) -        , ("declarationbody", declBodyStr ) ] -        declarationTemplate----- | -mkTopLevelFunctionCppDef :: STGroup String -                         -> String     -- ^ C prefix -                         -> TopLevelImportHeader-                         -> String -mkTopLevelFunctionCppDef templates cprefix tih =-  let cihs = tihClassDep tih-      declHeaderStr = "#include \"" ++ tihHeaderFileName tih <.> "h" ++ "\""-                      `connRet2`-                      (intercalate "\n" (nub (map genAllCppHeaderInclude cihs)))-                      `connRet2`-                      ((intercalateWith connRet (\x->"#include \""++x++"\"") . map (T.unHdrName . cihSelfHeader)) cihs)-      allns = nubBy ((==) `on` unNamespace) (tihClassDep tih >>= cihNamespace)-      namespaceStr = do ns <- allns -                        ("using namespace " ++ unNamespace ns ++ ";\n")-      declBodyStr    = intercalateWith connRet genTopLevelFuncCppDefinition (tihFuncs tih)--  in  renderTemplateGroup -        templates -        [ ("header", declHeaderStr)-        , ("namespace", namespaceStr)-        , ("cppbody", declBodyStr ) ] -        definitionTemplate---- | -mkFFIHsc :: STGroup String -         -> ClassModule -         -> String -mkFFIHsc templates m = -    renderTemplateGroup templates -                        [ ("ffiHeader", ffiHeaderStr)-                        , ("ffiImport", ffiImportStr)-                        , ("cppInclude", cppIncludeStr)-                        , ("hsFunctionBody", genAllHsFFI headers) ]-                        ffiHscFileName-  where mname = cmModule m-        -- classes = cmClass m-        headers = cmCIH m-        ffiHeaderStr = "module " ++ mname <.> "FFI where\n"-        ffiImportStr = "import " ++ mname <.> "RawType\n"-                       ++ genImportInFFI m-        cppIncludeStr = genModuleIncludeHeader headers---- |                      -mkRawTypeHs :: STGroup String -            -> ClassModule -            -> String-mkRawTypeHs templates m = -    renderTemplateGroup templates [ ("rawtypeHeader", rawtypeHeaderStr) -                                  , ("rawtypeBody", rawtypeBodyStr)] rawtypeHsFileName-  where rawtypeHeaderStr = "module " ++ cmModule m <.> "RawType where\n"-        classes = cmClass m-        rawtypeBodyStr = -          intercalateWith connRet2 hsClassRawType (filter (not.isAbstractClass) classes)---- | -mkInterfaceHs :: AnnotateMap -              -> STGroup String -              -> ClassModule -              -> String    -mkInterfaceHs amap templates m = -    renderTemplateGroup templates [ ("ifaceHeader", ifaceHeaderStr) -                                  , ("ifaceImport", ifaceImportStr)-                                  , ("ifaceBody", ifaceBodyStr)]  "Interface.hs" -  where ifaceHeaderStr = "module " ++ cmModule m <.> "Interface where\n" -        classes = cmClass m-        ifaceImportStr = genImportInInterface m-        ifaceBodyStr = -          runReader (genAllHsFrontDecl classes) amap -          `connRet2`-          intercalateWith connRet hsClassExistType (filter (not.isAbstractClass) classes) -          `connRet2`-          runReader (genAllHsFrontUpcastClass (filter (not.isAbstractClass) classes)) amap  -          `connRet2`-          runReader (genAllHsFrontDowncastClass (filter (not.isAbstractClass) classes)) amap---- | -mkCastHs :: STGroup String -> ClassModule -> String    -mkCastHs templates m  = -    renderTemplateGroup templates [ ("castHeader", castHeaderStr) -                                  , ("castImport", castImportStr)-                                  , ("castBody", castBodyStr) ]  -                                  castHsFileName-  where castHeaderStr = "module " ++ cmModule m <.> "Cast where\n" -        classes = cmClass m-        castImportStr = genImportInCast m-        castBodyStr = -          genAllHsFrontInstCastable classes -          `connRet2`-          intercalateWith connRet2 genHsFrontInstCastableSelf classes---- | -mkImplementationHs :: AnnotateMap -                   -> STGroup String  -- ^ template -                   -> ClassModule -                   -> String-mkImplementationHs amap templates m = -    renderTemplateGroup templates -                        [ ("implHeader", implHeaderStr) -                        , ("implImport", implImportStr)-                        , ("implBody", implBodyStr ) ]-                        "Implementation.hs"-  where classes = cmClass m-        implHeaderStr = "module " ++ cmModule m <.> "Implementation where\n" -        implImportStr = genImportInImplementation m-        f y = intercalateWith connRet (flip genHsFrontInst y) (y:class_allparents y )-        g y = intercalateWith connRet (flip genHsFrontInstExistVirtual y) (y:class_allparents y )--        implBodyStr =  -          intercalateWith connRet2 f classes-          `connRet2` -          intercalateWith connRet2 g (filter (not.isAbstractClass) classes)-          `connRet2`-          runReader (genAllHsFrontInstNew classes) amap-          `connRet2`-          genAllHsFrontInstNonVirtual classes-          `connRet2`-          intercalateWith connRet id (mapMaybe genHsFrontInstStatic classes)-          `connRet2`-          genAllHsFrontInstExistCommon (filter (not.isAbstractClass) classes)-        --- | -mkExistentialEach :: STGroup String -                  -> Class -                  -> [Class] -                  -> String -mkExistentialEach templates mother daughters =   -  let makeOneDaughterGADTBody daughter = render hsExistentialGADTBodyTmpl -                                                [ ( "mother", (fst.hsClassName) mother ) -                                                , ( "daughter",(fst.hsClassName) daughter ) ] -      makeOneDaughterCastBody daughter = render hsExistentialCastBodyTmpl-                                                [ ( "mother", (fst.hsClassName) mother ) -                                                , ( "daughter", (fst.hsClassName) daughter) ] -      gadtBody = intercalate "\n" (map makeOneDaughterGADTBody daughters)-      castBody = intercalate "\n" (map makeOneDaughterCastBody daughters)-      str = renderTemplateGroup -              templates -              [ ( "mother" , (fst.hsClassName) mother ) -              , ( "GADTbody" , gadtBody ) -              , ( "castbody" , castBody ) ]-              "ExistentialEach.hs" -  in  str---- | -mkExistentialHs :: STGroup String -                -> ClassGlobal -                -> ClassModule -                -> String-mkExistentialHs templates cglobal m = -  let classes = filter (not.isAbstractClass) (cmClass m)-      dsmap = cgDaughterSelfMap cglobal-      makeOneMother :: Class -> String -      makeOneMother mother = -        let daughters = case M.lookup (getClassModuleBase mother) dsmap of -                             Nothing -> error "error in mkExistential"-                             Just lst -> filter (not.isAbstractClass) lst-            str = mkExistentialEach templates mother daughters-        in  str -      existEachBody = intercalateWith connRet makeOneMother classes-      existHeaderStr = "module " ++ cmModule m <.> "Existential where"-      existImportStr = genImportInExistential dsmap m-      hsfilestr = renderTemplateGroup -                    templates -                    [ ("existHeader", existHeaderStr)-                    , ("existImport", existImportStr)-                    , ("modname", cmModule m)-                    , ( "existEachBody" , existEachBody) ]-                  "Existential.hs" -  in  hsfilestr---- | -mkInterfaceHSBOOT :: STGroup String -> String -> String -mkInterfaceHSBOOT templates mname = -  let cname = last (splitOn "." mname)-      hsbootbodystr = "class " ++ 'I':cname ++ " a" -      hsbootstr = renderTemplateGroup -                    templates -                    [ ("moduleName", mname <.> "Interface") -                    , ("hsBootBody", hsbootbodystr)-                    ]-                    hsbootTemplate-  in hsbootstr ------ | -mkModuleHs :: STGroup String -           -> ClassModule -           -> String -mkModuleHs templates m = -    let str = renderTemplateGroup -                templates -                [ ("moduleName", cmModule m) -                , ("exportList", genExportList (cmClass m)) -                , ("importList", genImportInModule (cmClass m))-                ]-                moduleTemplate -    in str----- | -mkPkgHs :: String -> STGroup String -> [ClassModule] -> TopLevelImportHeader -> String -mkPkgHs modname templates mods tih = -    let tfns = tihFuncs tih -        exportListStr = intercalateWith (conn "\n, ") ((\x->"module " ++ x).cmModule) mods -                        ++ if null tfns -                           then "" -                           else "\n, " ++ intercalateWith (conn "\n, ") hsFrontNameForTopLevelFunction tfns -        importListStr = intercalateWith connRet ((\x->"import " ++ x).cmModule) mods-                        ++ if null tfns -                           then "" -                           else "" `connRet2` "import Foreign.C" `connRet` "import Foreign.Ptr"-                                `connRet` "import FFICXX.Runtime.Cast" -                                `connRet`-                                intercalateWith connRet -                                  ((\x->"import " ++ modname ++ "." ++ x ++ ".RawType")-                                   .fst.hsClassName.cihClass) (tihClassDep tih)-        topLevelDefStr = intercalateWith connRet2 (genTopLevelFuncFFI tih) tfns -                         `connRet2`-                         intercalateWith connRet2 genTopLevelFuncDef tfns-        str = renderTemplateGroup -                templates -                [ ("summarymod", modname)-                , ("exportList", exportListStr) -                , ("importList", importListStr) -                , ("topLevelDef", topLevelDefStr) -                ]-                pkgModuleTemplate-    in str -       ---  --- |-mkPackageInterface :: T.PackageInterface -                   -> T.PackageName -                   -> [ClassImportHeader] -                   -> T.PackageInterface-mkPackageInterface pinfc pkgname = foldr f pinfc -  where f cih repo = -          let name = (class_name . cihClass) cih -              header = cihSelfHeader cih -          in set (at (pkgname,T.ClsName name)) (Just header) repo-
− lib/FFICXX/Generate/Generator/Driver.hs 
@@ -1,236 +0,0 @@--------------------------------------------------------------------------------- |--- Module      : FFICXX.Generate.Generator.Driver--- Copyright   : (c) 2011-2015 Ian-Woo Kim--- --- License     : BSD3--- Maintainer  : ianwookim@gmail.com--- Stability   : experimental--- Portability : GHC-----------------------------------------------------------------------------------module FFICXX.Generate.Generator.Driver where--import           Control.Applicative ((<$>))-import           Control.Monad (when, forM_)-import qualified Data.ByteString.Lazy.Char8 as L-import           Data.Digest.Pure.MD5-import           System.Directory -import           System.FilePath-import           System.IO-import           System.Process-import           Text.StringTemplate----import FFICXX.Generate.Type.Class-import FFICXX.Generate.Type.Annotate-import FFICXX.Generate.Type.PackageInterface -import FFICXX.Generate.Generator.ContentMaker -import FFICXX.Generate.Util----------- Header and Cpp file--------- | -writeTypeDeclHeaders :: STGroup String -                     -> FilePath -                     -> TypeMacro  -- ^ type macro -                     -> String  -- ^ cprefix -                     -> [ClassImportHeader]-                     -> IO ()-writeTypeDeclHeaders templates wdir typemacro cprefix headers = do -  let fn = wdir </> cprefix ++ "Type.h"-      classes = map cihClass headers-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkTypeDeclHeader templates typemacro classes)---- | -writeDeclHeaders :: STGroup String  -                 -> FilePath -                 -> TypeMacro -                 -> String  -- ^ c prefix -                 -> ClassImportHeader-                 -> IO () -writeDeclHeaders templates wdir typemacroprefix cprefix header = do -  let fn = wdir </> (unHdrName (cihSelfHeader header))-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkDeclHeader templates typemacroprefix cprefix header)---- | -writeTopLevelFunctionHeaders :: STGroup String  -                             -> FilePath -                             -> TypeMacro -                             -> String  -- ^ c prefix -                             -> TopLevelImportHeader-                             -> IO () -writeTopLevelFunctionHeaders templates wdir typemacroprefix cprefix tih = do -  let fn = wdir </> tihHeaderFileName tih <.> "h"-  withFile fn WriteMode $ \h -> -    hPutStrLn h (mkTopLevelFunctionHeader templates typemacroprefix cprefix tih)-----writeCppDef :: STGroup String -> FilePath -> ClassImportHeader -> IO () -writeCppDef templates wdir header = do -  let fn = wdir </> cihSelfCpp header-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkDefMain templates header)----- | -writeTopLevelFunctionCppDef :: STGroup String  -                            -> FilePath -                            -> TypeMacro -                            -> String  -- ^ c prefix -                            -> TopLevelImportHeader-                            -> IO () -writeTopLevelFunctionCppDef templates wdir typemacroprefix cprefix tih = do -  let fn = wdir </> tihHeaderFileName tih <.> "cpp"-  withFile fn WriteMode $ \h -> hPutStrLn h (mkTopLevelFunctionCppDef templates cprefix tih)----- | -writeRawTypeHs :: STGroup String -> FilePath -> ClassModule -> IO ()-writeRawTypeHs templates wdir m = do-  let fn = wdir </> cmModule m <.> rawtypeHsFileName-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkRawTypeHs templates m) ---- | -writeFFIHsc :: STGroup String -> FilePath -> ClassModule -> IO ()-writeFFIHsc templates wdir m = do -  let fn = wdir </> cmModule m <.> ffiHscFileName-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkFFIHsc templates m)---- | -writeInterfaceHs :: AnnotateMap -> STGroup String -> FilePath -                 -> ClassModule -                 -> IO ()-writeInterfaceHs amap templates wdir m = do -  let fn = wdir </> cmModule m <.> interfaceHsFileName-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkInterfaceHs amap templates m)---- |-writeCastHs :: STGroup String -> FilePath -> ClassModule -> IO ()-writeCastHs templates wdir m = do -  let fn = wdir </> cmModule m <.> castHsFileName-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkCastHs templates m)---- | -writeImplementationHs :: AnnotateMap -                      -> STGroup String -                      -> FilePath -                      -> ClassModule -                      -> IO ()-writeImplementationHs amap templates wdir m = do -  let fn = wdir </> cmModule m <.> implementationHsFileName-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkImplementationHs amap templates m)---- | -writeExistentialHs :: STGroup String -                   -> ClassGlobal -                   -> FilePath -                   -> ClassModule -                   -> IO ()-writeExistentialHs templates cglobal wdir m = do -  let fn = wdir </> cmModule m <.> existentialHsFileName-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkExistentialHs templates cglobal m)---- | -writeInterfaceHSBOOT :: STGroup String -> FilePath -> String -> IO ()-writeInterfaceHSBOOT templates wdir mname = do -  let fn = wdir </> mname <.> "Interface" <.> "hs-boot"-  withFile fn WriteMode $ \h -> hPutStrLn h (mkInterfaceHSBOOT templates mname)---- |-writeModuleHs :: STGroup String -> FilePath -> ClassModule -> IO () -writeModuleHs templates wdir m = do -  let fn = wdir </> cmModule m <.> "hs"-  withFile fn WriteMode $ \h -> do -    hPutStrLn h (mkModuleHs templates m)---- | -writePkgHs :: String -- ^ summary module -           -> STGroup String -           -> FilePath -           -> [ClassModule] -           -> TopLevelImportHeader-           -> IO () -writePkgHs modname templates wdir mods tih = do -  let fn = wdir </> modname <.> "hs"-      str = mkPkgHs modname templates mods tih-  withFile fn WriteMode $ \h -> hPutStrLn h str---notExistThenCreate :: FilePath -> IO () -notExistThenCreate dir = do -    b <- doesDirectoryExist dir-    if b then return () else system ("mkdir -p " ++ dir) >> return ()---{- --- | now only create directory-copyPredefined :: FilePath -> FilePath -> String -> IO () -copyPredefined _tdir _ddir _prefix = do -    return () -    -- notExistThenCreate (ddir </> prefix)-    -- copyFile (tdir </> "TypeCast.hs" ) (ddir </> prefix </> "TypeCast.hs") --}--copyFileWithMD5Check :: FilePath -> FilePath -> IO () -copyFileWithMD5Check src tgt = do-  b <- doesFileExist tgt -  if b -    then do -      srcmd5 <- md5 <$> L.readFile src  -      tgtmd5 <- md5 <$> L.readFile tgt -      if srcmd5 == tgtmd5 then return () else copyFile src tgt -    else copyFile src tgt  ---copyCppFiles :: FilePath -> FilePath -> String -> (TopLevelImportHeader,[ClassImportHeader]) -> IO ()-copyCppFiles wdir ddir cprefix (tih,cihs) = do -  let thfile = cprefix ++ "Type.h"-      tlhfile = tihHeaderFileName tih <.> "h"-      tlcppfile = tihHeaderFileName tih <.> "cpp"-  copyFileWithMD5Check (wdir </> thfile) (ddir </> thfile) -  doesFileExist (wdir </> tlhfile) -    >>= flip when (copyFileWithMD5Check (wdir </> tlhfile) (ddir </> tlhfile))-  doesFileExist (wdir </> tlcppfile) -    >>= flip when (copyFileWithMD5Check (wdir </> tlcppfile) (ddir </> tlcppfile))-  forM_ cihs $ \header-> do -    let hfile = unHdrName (cihSelfHeader header)-        cppfile = cihSelfCpp header-    copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) -    copyFileWithMD5Check (wdir </> cppfile) (ddir </> cppfile)--copyModule :: FilePath -> FilePath -> String -> ClassModule -> IO ()-copyModule wdir ddir summarymod m = do -  let modbase = cmModule m -  let onefilecopy fname = do -        let (fnamebody,fnameext) = splitExtension fname-            (mdir,mfile) = moduleDirFile fnamebody-            origfpath = wdir </> fname-            (mfile',_mext') = splitExtension mfile-            newfpath = ddir </> mdir </> mfile' ++ fnameext   -        b <- doesFileExist origfpath -        when b $ do -          notExistThenCreate (ddir </> mdir) -          copyFileWithMD5Check origfpath newfpath --  onefilecopy $ modbase ++ ".hs"-  onefilecopy $ modbase ++ ".RawType.hs"-  onefilecopy $ modbase ++ ".FFI.hsc"-  onefilecopy $ modbase ++ ".Interface.hs"-  onefilecopy $ modbase ++ ".Cast.hs"-  onefilecopy $ modbase ++ ".Implementation.hs"-  onefilecopy $ modbase ++ ".Interface.hs-boot"-  onefilecopy $ summarymod <.> "hs"-  return ()
lib/FFICXX/Generate/QQ/Verbatim.hs view
@@ -16,8 +16,10 @@ import Language.Haskell.TH.Lib  verbatim :: QuasiQuoter-verbatim = QuasiQuoter { -             quoteExp = litE . stringL---           , quotePat = litP . stringP-           } +verbatim = QuasiQuoter{ quoteExp = litE . stringL+                      , quotePat = undefined+                      , quoteType = undefined+                      , quoteDec = undefined+                      --           , quotePat = litP . stringP+                      }
lib/FFICXX/Generate/Type/Class.hs view
@@ -1,10 +1,11 @@+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-}  ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Type.Class--- Copyright   : (c) 2011-2013,2015 Ian-Woo Kim+-- Copyright   : (c) 2011-2017 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -15,25 +16,24 @@  module FFICXX.Generate.Type.Class where -import Control.Applicative ((<$>),(<*>))-import Data.Char-import Data.Default (Default(def))-import Data.List-import Data.Monoid-import qualified Data.Map as M-import System.FilePath+import           Control.Applicative               ( (<$>),(<*>) )+import           Control.Monad.State+import           Data.Char+import           Data.Default                      ( Default(def) )+import           Data.List+import qualified Data.Map                     as M+import           Data.Monoid                       ( (<>) )+import           Language.Haskell.Exts.Syntax      ( Asst(..), Context+                                                   , Splice(..), Type(..), unit_tycon+                                                   )+import           System.FilePath ---import FFICXX.Generate.Util-import FFICXX.Generate.Type.PackageInterface+import           FFICXX.Generate.Util+import           FFICXX.Generate.Util.HaskellSrcExts  -- some type aliases --- type HeaderFileName = String --- type ClassName = String--- -- | C types data CTypes = CTString             | CTChar@@ -54,6 +54,7 @@ -- | C++ types data CPPTypes = CPTClass Class               | CPTClassRef Class+              | CPTClassCopy Class               deriving Show  -- | const flag@@ -64,10 +65,15 @@            | SelfType            | CT  CTypes IsConst            | CPT CPPTypes IsConst+           | TemplateApp { tapp_hstemplate :: TemplateClass+                         , tapp_HaskellTypeForParam :: String+                         , tapp_CppTypeForParam :: String }+           | TemplateType TemplateClass+           | TemplateParam String            deriving Show  cvarToStr :: CTypes -> IsConst -> String -> String-cvarToStr ctyp isconst varname = (ctypToStr ctyp isconst) `connspace` varname+cvarToStr ctyp isconst varname = ctypToStr ctyp isconst <> " " <> varname  ctypToStr :: CTypes -> IsConst -> String ctypToStr ctyp isconst =@@ -84,10 +90,10 @@         CTVoidStar -> "void*"         CTIntStar -> "int*"         CTCharStarStar -> "char**"-        CPointer s -> ctypToStr s NoConst ++ "*"-        CRef s -> ctypToStr s NoConst ++ "*"+        CPointer s -> ctypToStr s NoConst <> "*"+        CRef s -> ctypToStr s NoConst <> "*"   in case isconst of-        Const   -> "const" `connspace` typword+        Const   -> "const" <> " " <> typword         NoConst -> typword  @@ -241,6 +247,8 @@ cppclass :: Class -> String -> (Types, String) cppclass c vname = ( cppclass_ c, vname) ++ cppclassconst :: Class -> String -> (Types, String) cppclassconst c vname = ( CPT (CPTClass c) Const, vname) @@ -250,7 +258,13 @@ cppclassref :: Class -> String -> (Types, String) cppclassref c vname = (cppclassref_ c, vname) +cppclasscopy_ :: Class -> Types+cppclasscopy_ c = CPT (CPTClassCopy c) NoConst +cppclasscopy :: Class -> String -> (Types, String)+cppclasscopy c vname = (cppclasscopy_ c, vname)++ hsCTypeName :: CTypes -> String hsCTypeName CTString = "CString" hsCTypeName CTChar   = "CChar"@@ -264,12 +278,8 @@ hsCTypeName CTVoidStar = "(Ptr ())" hsCTypeName CTIntStar = "(Ptr CInt)" hsCTypeName CTCharStarStar = "(Ptr (CString))"-hsCTypeName (CPointer t) = "(Ptr " ++ hsCTypeName t ++ ")"-hsCTypeName (CRef t) = "(Ptr " ++ hsCTypeName t ++ ")"--hsCppTypeName :: CPPTypes -> String-hsCppTypeName (CPTClass c) =  "(Ptr "++rawname++")"  where rawname = snd (hsClassName c)-hsCppTypeName (CPTClassRef c) = "(Ptr "++rawname++")" where rawname = snd (hsClassName c)+hsCTypeName (CPointer t) = "(Ptr " <> hsCTypeName t <> ")"+hsCTypeName (CRef t) = "(Ptr " <> hsCTypeName t <> ")"  ------------- @@ -315,13 +325,8 @@     in toLower x : xs  -data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String-                                                 , tihClassDep :: [ClassImportHeader]-                                                 , tihFuncs :: [TopLevelFunction]-                                                 }  - isNewFunc :: Function -> Bool isNewFunc (Constructor _ _) = True isNewFunc _ = False@@ -331,10 +336,16 @@ isDeleteFunc _ = False  isVirtualFunc :: Function -> Bool-isVirtualFunc (Destructor _)           = True-isVirtualFunc (Virtual _ _ _ _)        = True-isVirtualFunc _ = False+isVirtualFunc (Destructor _)          = True+isVirtualFunc (Virtual _ _ _ _)       = True+isVirtualFunc _                       = False +isNonVirtualFunc :: Function -> Bool+isNonVirtualFunc (NonVirtual _ _ _ _) = True+isNonVirtualFunc _                    = False+++ isStaticFunc :: Function -> Bool isStaticFunc (Static _ _ _ _) = True isStaticFunc _ = False@@ -354,15 +365,16 @@  argToString :: (Types,String) -> String argToString (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname-argToString (SelfType, varname) = "Type ## _p " ++ varname+argToString (SelfType, varname) = "Type ## _p " <> varname argToString (CPT (CPTClass c) isconst, varname) = case isconst of-    Const   -> "const_" ++ cname ++ "_p " ++ varname-    NoConst -> cname ++ "_p " ++ varname+    Const   -> "const_" <> cname <> "_p " <> varname+    NoConst -> cname <> "_p " <> varname   where cname = class_name c argToString (CPT (CPTClassRef c) isconst, varname) = case isconst of-    Const   -> "const_" ++ cname ++ "_p " ++ varname-    NoConst -> cname ++ "_p " ++ varname+    Const   -> "const_" <> cname <> "_p " <> varname+    NoConst -> cname <> "_p " <> varname   where cname = class_name c+argToString (TemplateApp _ _ _,varname) = "void* " <> varname argToString _ = error "undefined argToString"  argsToString :: Args -> String@@ -375,11 +387,13 @@   argToCallString :: (Types,String) -> String+argToCallString (CT (CRef _) _,varname) = "(*"<> varname<> ")" argToCallString (CPT (CPTClass c) _,varname) =-    "to_nonconst<"++str++","++str++"_t>("++varname++")" where str = class_name c+    "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = class_name c argToCallString (CPT (CPTClassRef c) _,varname) =-    "to_nonconstref<"++str++","++str++"_t>(*"++varname++")" where str = class_name c-argToCallString (CT (CRef _) _,varname) = "(*"++ varname++ ")"+    "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c+argToCallString (TemplateApp _ _ cp,varname) =+    "to_nonconst<"<>str<>",void>("<>varname<>")" where str = cp   argToCallString (_,varname) = varname  argsToCallString :: Args -> String@@ -390,11 +404,71 @@ rettypeToString (CT ctyp isconst) = ctypToStr ctyp isconst rettypeToString Void = "void" rettypeToString SelfType = "Type ## _p"-rettypeToString (CPT (CPTClass c) _) = str ++ "_p"-  where str = class_name c-rettypeToString (CPT (CPTClassRef c) _) = str ++ "_p"-  where str = class_name c+rettypeToString (CPT (CPTClass c) _) = class_name c <> "_p"+rettypeToString (CPT (CPTClassRef c) _) = class_name c <> "_p"+rettypeToString (CPT (CPTClassCopy c) _) = class_name c <> "_p"+rettypeToString (TemplateApp _ _ _) = "void*"+rettypeToString (TemplateType _) = "void*"+rettypeToString (TemplateParam _) = "Type ## _p" +tmplArgToString :: TemplateClass -> (Types,String) -> String+tmplArgToString _  (CT ctyp isconst, varname) = cvarToStr ctyp isconst varname+tmplArgToString t (SelfType, varname) = tclass_oname t <> "* " <> varname+tmplArgToString _ (CPT (CPTClass c) isconst, varname) =+  case isconst of+    Const   -> "const_" <> class_name c <> "_p " <> varname+    NoConst -> class_name c <> "_p " <> varname+tmplArgToString _ (CPT (CPTClassRef c) isconst, varname) =+  case isconst of+    Const   -> "const_" <> class_name c <> "_p " <> varname+    NoConst -> class_name c <> "_p " <> varname+tmplArgToString _ (TemplateApp _ _ _,_v) = error "tmpArgToString: TemplateApp"+tmplArgToString _ (TemplateType _,v) = "void* " <> v+tmplArgToString _ (TemplateParam _,v) = "Type " <> v+tmplArgToString _ _ = error "tmplArgToString: undefined"++tmplAllArgsToString :: Selfness+                    -> TemplateClass+                    -> Args+                    -> String+tmplAllArgsToString s t args =+  let args' = case s of+                Self -> (TemplateType t, "p") : args+                NoSelf -> args+  in  intercalateWith conncomma (tmplArgToString t) args'++++tmplArgToCallString :: (Types,String) -> String+tmplArgToCallString (CPT (CPTClass c) _,varname) =+    "to_nonconst<"<>str<>","<>str<>"_t>("<>varname<>")" where str = class_name c+tmplArgToCallString (CPT (CPTClassRef c) _,varname) =+    "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c+tmplArgToCallString (CT (CRef _) _,varname) = "(*"<> varname<> ")"+tmplArgToCallString (_,varname) = varname++tmplAllArgsToCallString :: Args -> String+tmplAllArgsToCallString = intercalateWith conncomma tmplArgToCallString++++tmplRetTypeToString :: Bool   -- ^ is Simple type?+                    -> Types+                    -> String+tmplRetTypeToString _ (CT ctyp isconst) = ctypToStr ctyp isconst+tmplRetTypeToString _ Void = "void"+tmplRetTypeToString _ SelfType = "void*"+tmplRetTypeToString _ (CPT (CPTClass c) _) = class_name c <> "_p"+tmplRetTypeToString _ (CPT (CPTClassRef c) _) = class_name c <> "_p"+tmplRetTypeToString _ (CPT (CPTClassCopy c) _) = class_name c <> "_p"+tmplRetTypeToString _ (TemplateApp _ _ _) = "void*"+tmplRetTypeToString _ (TemplateType _) = "void*"+tmplRetTypeToString b (TemplateParam _) = if b+                                          then "Type"+                                          else "Type ## _p"+++ --------  newtype ProtectedMethod = Protected { unProtected :: [String] }@@ -433,34 +507,35 @@                            , class_funcs :: [Function]                            } +data TemplateFunction = TFun { tfun_ret :: Types+                             , tfun_name :: String+                             , tfun_oname :: String+                             , tfun_args :: Args+                             , tfun_alias :: Maybe String }+                      | TFunNew { tfun_new_args :: Args }+                      | TFunDelete -newtype Namespace = NS { unNamespace :: String } deriving (Show)+data TemplateClass = TmplCls { tclass_cabal :: Cabal+                             , tclass_name :: String+                             , tclass_oname :: String+                             , tclass_param :: String+                             , tclass_funcs :: [TemplateFunction]+                             } -data ClassImportHeader = ClassImportHeader-                       { cihClass :: Class-                       , cihSelfHeader :: HeaderName-                       , cihNamespace :: [Namespace]-                       , cihSelfCpp :: String-                       , cihIncludedHPkgHeadersInH :: [HeaderName] -- [String]-                       , cihIncludedHPkgHeadersInCPP :: [HeaderName] -- [String]-                       , cihIncludedCPkgHeaders :: [HeaderName]-                       } deriving (Show)+instance Show TemplateClass where+  show x = show (tclass_name x <> " " <> tclass_param x) -data ClassModule = ClassModule-                   { cmModule :: String-                   , cmClass :: [Class]-                   , cmCIH :: [ClassImportHeader]-                   , cmImportedModulesHighNonSource :: [String]-                   , cmImportedModulesRaw :: [String]-                   , cmImportedModulesHighSource :: [String]-                   , cmImportedModulesForFFI :: [String]-                   } deriving (Show) + data ClassGlobal = ClassGlobal                    { cgDaughterSelfMap :: DaughterMap                    , cgDaughterMap :: DaughterMap                    } +data Selfness = Self | NoSelf+              ++ -- | Check abstract class  isAbstractClass :: Class -> Bool@@ -482,14 +557,17 @@ class_allparents c = let ps = class_parents c                      in  if null ps                            then []-                           else nub (ps ++ (concatMap class_allparents ps))+                           else nub (ps <> (concatMap class_allparents ps))   getClassModuleBase :: Class -> String getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName) +getTClassModuleBase :: TemplateClass -> String+getTClassModuleBase = (<.>) <$> (cabal_moduleprefix.tclass_cabal) <*> (fst.hsTemplateClassName)  + -- | Daughter map not including itself mkDaughterMap :: [Class] -> DaughterMap mkDaughterMap = foldl mkDaughterMapWorker M.empty@@ -529,65 +607,87 @@ ctypToHsTyp _c (CT CTCharStarStar _) = "(Ptr CString)" ctypToHsTyp _c (CT (CPointer t) _) = hsCTypeName (CPointer t) ctypToHsTyp _c (CT (CRef t) _) = hsCTypeName (CRef t)-ctypToHsTyp _c (CPT (CPTClass c') _) = class_name c'-ctypToHsTyp _c (CPT (CPTClassRef c') _) = class_name c'+ctypToHsTyp _c (CPT (CPTClass c') _) = (fst . hsClassName) c'+ctypToHsTyp _c (CPT (CPTClassRef c') _) = (fst . hsClassName) c'+ctypToHsTyp _c (CPT (CPTClassCopy c') _) = (fst . hsClassName) c'+ctypToHsTyp _c (TemplateApp t p _) = "("<> tclass_name t <> " " <> p <> ")"+ctypToHsTyp _c (TemplateType t) = "("<> tclass_name t <> " " <> tclass_param t <> ")"+ctypToHsTyp _c (TemplateParam p) = "("<> p <> ")"  +-- |+convertC2HS :: CTypes -> Type+convertC2HS CTString     = tycon "CString"+convertC2HS CTChar       = tycon "CChar"+convertC2HS CTInt        = tycon "CInt"+convertC2HS CTUInt       = tycon "CUInt"+convertC2HS CTLong       = tycon "CLong"+convertC2HS CTULong      = tycon "CULong"+convertC2HS CTDouble     = tycon "CDouble"+convertC2HS CTDoubleStar = TyApp (tycon "Ptr") (tycon "CDouble")+convertC2HS CTBool       = tycon "CInt"+convertC2HS CTVoidStar   = TyApp (tycon "Ptr") unit_tycon+convertC2HS CTIntStar    = TyApp (tycon "Ptr") (tycon "CInt")+convertC2HS CTCharStarStar = TyApp (tycon "Ptr") (tycon "CString")+convertC2HS (CPointer t) = TyApp (tycon "Ptr") (convertC2HS t)+convertC2HS (CRef t)     = TyApp (tycon "Ptr") (convertC2HS t)++-- |+convertCpp2HS :: Maybe Class -> Types -> Type+convertCpp2HS _c Void                  = unit_tycon+convertCpp2HS (Just c) SelfType        = tycon ((fst.hsClassName) c)+convertCpp2HS Nothing SelfType         = error "convertCpp2HS : SelfType but no class "+convertCpp2HS _c (CT t _)              = convertC2HS t+convertCpp2HS _c (CPT (CPTClass c') _)     = (tycon . fst . hsClassName) c'+convertCpp2HS _c (CPT (CPTClassRef c') _)  = (tycon . fst . hsClassName) c'+convertCpp2HS _c (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c'+convertCpp2HS _c (TemplateApp t p _)      = TyApp (tycon (tclass_name t)) (tycon p)+convertCpp2HS _c (TemplateType t)         = TyApp (tycon (tclass_name t)) (mkTVar (tclass_param t))+convertCpp2HS _c (TemplateParam p)         = mkTVar p++-- |+convertCpp2HS4Tmpl :: Type -> Maybe Class -> Type -> Types -> Type+convertCpp2HS4Tmpl _ _c _ Void                  = unit_tycon+convertCpp2HS4Tmpl _ (Just c) _ SelfType        = tycon ((fst.hsClassName) c)+convertCpp2HS4Tmpl _ Nothing _ SelfType         = error "convertCpp2HS4Tmpl : SelfType but no class "+convertCpp2HS4Tmpl _ _c _ (CT t _)              = convertC2HS t+convertCpp2HS4Tmpl _ _c _ (CPT (CPTClass c') _)     = (tycon . fst . hsClassName) c'+convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassRef c') _)  = (tycon . fst . hsClassName) c'+convertCpp2HS4Tmpl _ _c _ (CPT (CPTClassCopy c') _) = (tycon . fst . hsClassName) c'+convertCpp2HS4Tmpl e _c _ (TemplateApp _ _ _ )     = e+convertCpp2HS4Tmpl e _c _ (TemplateType _)         = e+convertCpp2HS4Tmpl _ _c t (TemplateParam _)        = t++++ typeclassName :: Class -> String typeclassName c = 'I' : fst (hsClassName c) +typeclassNameT :: TemplateClass -> String+typeclassNameT c = 'I' : fst (hsTemplateClassName c)+++ typeclassNameFromStr :: String -> String typeclassNameFromStr = ('I':)  hsClassName :: Class -> (String, String)  -- ^ High-level, 'Raw'-level hsClassName c =   let cname = maybe (class_name c) id (class_alias c)-  in (cname, "Raw" ++ cname)+  in (cname, "Raw" <> cname) +hsTemplateClassName :: TemplateClass -> (String, String)  -- ^ High-level, 'Raw'-level+hsTemplateClassName t =+  let tname = tclass_name t+  in (tname, "Raw" <> tname)+ existConstructorName :: Class -> String existConstructorName c = 'E' : (fst.hsClassName) c --- | this is for FFI type.-hsFuncTyp :: Class -> Function -> String-hsFuncTyp c f = let args = genericFuncArgs f-                    ret  = genericFuncRet f-                in  selfstr ++ " -> " ++ concatMap ((++ " -> ") . hsargtype . fst) args ++ hsrettype ret -  where (_hcname,rcname) = hsClassName c-        selfstr = "(Ptr " ++ rcname ++ ")"--        hsargtype (CT ctype _) = hsCTypeName ctype-        hsargtype (CPT x _) = hsCppTypeName x-        hsargtype SelfType = selfstr-        hsargtype _ = error "undefined hsargtype"--        hsrettype Void = "IO ()"-        hsrettype SelfType = "IO " ++ selfstr-        hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype-        hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x---- | this is for FFI-hsFuncTypNoSelf :: Class -> Function -> String-hsFuncTypNoSelf c f = let args = genericFuncArgs f-                          ret  = genericFuncRet f-                      in  intercalateWith connArrow id $ map (hsargtype . fst) args ++ [hsrettype ret]--  where (_hcname,rcname) = hsClassName c-        selfstr = "(Ptr " ++ rcname ++ ")"--        hsargtype (CT ctype _) = hsCTypeName ctype-        hsargtype (CPT x _) = hsCppTypeName x-        hsargtype SelfType = selfstr-        hsargtype _ = error "undefined hsargtype"--        hsrettype Void = "IO ()"-        hsrettype SelfType = "IO " ++ selfstr-        hsrettype (CT ctype _) = "IO " ++ hsCTypeName ctype-        hsrettype (CPT x _ ) = "IO " ++ hsCppTypeName x-- hscFuncName :: Class -> Function -> String-hscFuncName c f = "c_" ++ toLowers (class_name c) ++ "_" ++ toLowers (aliasedFuncName c f)+hscFuncName c f = "c_" <> toLowers (class_name c) <> "_" <> toLowers (aliasedFuncName c f)  hsFuncName :: Class -> Function -> String hsFuncName c f = let (x:xs) = aliasedFuncName c f@@ -596,15 +696,15 @@ hsFuncXformer :: Function -> String hsFuncXformer func@(Constructor _ _) = let len = length (genericFuncArgs func)                                        in if len > 0-                                          then "xform" ++ show (len - 1)+                                          then "xform" <> show (len - 1)                                           else "xformnull" hsFuncXformer func@(Static _ _ _ _) =   let len = length (genericFuncArgs func)   in if len > 0-     then "xform" ++ show (len - 1)+     then "xform" <> show (len - 1)      else "xformnull" hsFuncXformer func = let len = length (genericFuncArgs func)-                     in "xform" ++ show len+                     in "xform" <> show len   genericFuncRet :: Function -> Types@@ -614,7 +714,6 @@     Virtual t _ _ _ -> t     NonVirtual t _ _ _-> t     Static t _ _ _ -> t-    -- AliasVirtual t _ _ _ -> t     Destructor _ -> void_  genericFuncArgs :: Function -> Args@@ -628,11 +727,10 @@     Virtual _ str _ a -> maybe str id a     NonVirtual _ str _ a-> maybe (nonvirtualName c str) id a     Static _ str _ a -> maybe (nonvirtualName c str) id a-    -- AliasVirtual _ _  _ alias -> alias     Destructor a -> maybe destructorName id a  cppStaticName :: Class -> Function -> String-cppStaticName c f = class_name c ++ "::" ++ func_name f+cppStaticName c f = class_name c <> "::" <> func_name f  cppFuncName :: Class -> Function -> String cppFuncName c f =   case f of@@ -640,14 +738,144 @@     Virtual _ _  _ _ -> func_name f     NonVirtual _ _ _ _-> func_name f     Static _ _ _ _-> cppStaticName c f-    -- AliasVirtual _ _  _ _ _ -> func_name f     Destructor _ -> destructorName  constructorName :: Class -> String-constructorName c = "new" ++ (fst.hsClassName) c+constructorName c = "new" <> (fst.hsClassName) c  nonvirtualName :: Class -> String -> String-nonvirtualName c str = (firstLower.fst.hsClassName) c ++ str+nonvirtualName c str = (firstLower.fst.hsClassName) c <> str  destructorName :: String destructorName = "delete"+++classConstraints :: Class -> Context+classConstraints = map ((\n->ClassA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents ++extractArgRetTypes :: Maybe Class -> Bool -> (Args,Types) -> ([Type],[Asst]) +extractArgRetTypes mc isvirtual (args,ret) = +  let  (typs,s) = flip runState ([],(0 :: Int)) $ do+                    as <- mapM (mktyp . fst) args+                    r <- case ret of +                           SelfType -> case mc of+                                         Nothing -> error "extractArgRetTypes: SelfType return but no class"+                                         Just c -> if isvirtual then return (mkTVar "a") else return $ tycon ((fst.hsClassName) c)+                           x -> (return . tycon . ctypToHsTyp Nothing) x+                    return (as ++ [TyApp (tycon "IO") r])+  in   (typs,fst s)+ where addclass c = do+         (ctxts,n) <- get +         let cname = (fst.hsClassName) c +             iname = typeclassNameFromStr cname +             tvar = mkTVar ('c' : show n)+             ctxt1 = ClassA (unqual iname) [tvar]+             ctxt2 = ClassA (unqual "FPtr") [tvar]+         put (ctxt1:ctxt2:ctxts,n+1)+         return tvar+       addstring = do +         (ctxts,n) <- get +         let tvar = mkTVar ('c' : show n)+             ctxt = ClassA (unqual "Castable") [tvar,tycon "CString"]+         put (ctxt:ctxts,n+1)+         return tvar++       mktyp typ = +         case typ of                  +           SelfType -> return (mkTVar "a")+           CT CTString Const -> addstring+           CT _ _   -> return $ tycon (ctypToHsTyp Nothing typ)+           CPT (CPTClass c') _    -> addclass c'+           CPT (CPTClassRef c') _ -> addclass c'+           -- it is not clear whether the following is okay or not.+           (TemplateApp t p _)    -> return (TyApp (tycon (tclass_name t)) (tycon p))+           (TemplateType t)       -> return (TyApp (tycon (tclass_name t)) (mkTVar (tclass_param t)))+           (TemplateParam p)      -> return (mkTVar p)+           Void -> return unit_tycon+           _ -> error ("No such c type : " <> show typ)  ++functionSignature :: Class -> Function -> Type+functionSignature c f =+  let (typs,ctxts) = extractArgRetTypes (Just c) (isVirtualFunc f) (genericFuncArgs f,genericFuncRet f)+      arg0+        | isVirtualFunc f    = (mkTVar "a" :)+        | isNonVirtualFunc f = (mkTVar (class_name c) :)+        | otherwise          = id+  in TyForall Nothing ctxts (foldr1 TyFun (arg0 typs))++functionSignatureT :: TemplateClass -> TemplateFunction -> Type+functionSignatureT t TFun {..} =+  let (hname,_) = hsTemplateClassName t+      tp = tclass_param t+      ctyp = convertCpp2HS Nothing tfun_ret+      arg0 =  (TyApp (tycon hname) (mkTVar tp) :)+      lst = arg0 (map (convertCpp2HS Nothing . fst) tfun_args)+  in foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp])+functionSignatureT t TFunNew {..} =+  let ctyp = convertCpp2HS Nothing (TemplateType t)+      lst = map (convertCpp2HS Nothing . fst) tfun_new_args+  in foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp])+functionSignatureT t TFunDelete =+  let ctyp = convertCpp2HS Nothing (TemplateType t)+  in ctyp `TyFun` (TyApp (tycon "IO") unit_tycon)++++functionSignatureTT :: TemplateClass -> TemplateFunction -> Type+functionSignatureTT t f = foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp])+ where+  (hname,_) = hsTemplateClassName t+  ctyp = case f of+           TFun {..}    -> convertCpp2HS4Tmpl e Nothing spl tfun_ret+           TFunNew {..} -> convertCpp2HS4Tmpl e Nothing spl (TemplateType t)+           TFunDelete   -> unit_tycon+  e = TyApp (tycon hname) spl+  spl = TySplice (ParenSplice (mkVar (tclass_param t)))+  lst =+    case f of+      TFun {..}    -> e : map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_args+      TFunNew {..} -> map (convertCpp2HS4Tmpl e Nothing spl . fst) tfun_new_args+      TFunDelete -> [e]++++-- | this is for FFI type.+hsFFIFuncTyp :: Maybe (Selfness, Class) -> (Args,Types) -> Type+hsFFIFuncTyp msc (args,ret) =+  foldr1 TyFun $ case msc of+                   Nothing         -> argtyps <> [TyApp (tycon "IO") rettyp]+                   Just (Self,_)   -> selftyp: argtyps <> [TyApp (tycon "IO") rettyp]+                   Just (NoSelf,_) -> argtyps <> [TyApp (tycon "IO") rettyp]+  where argtyps = map (hsargtype . fst) args+        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 (CT ctype _) = tycon (hsCTypeName ctype)+        hsargtype (CPT (CPTClass d) _)    = TyApp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsargtype (CPT (CPTClassRef d) _)    = TyApp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsargtype (TemplateApp t p _) = TyApp tyPtr (TyApp (tycon rawname) (tycon p))+          where rawname = snd (hsTemplateClassName t)+        hsargtype (TemplateType t) = TyApp tyPtr (TyApp (tycon rawname) (mkTVar (tclass_param t)))+          where rawname = snd (hsTemplateClassName t)+        hsargtype (TemplateParam p) = mkTVar p+        hsargtype SelfType     = selftyp+        hsargtype _ = error "hsFuncTyp: undefined hsargtype"++        hsrettype Void         = unit_tycon+        hsrettype SelfType     = selftyp+        hsrettype (CT ctype _) = tycon (hsCTypeName ctype)+        hsrettype (CPT (CPTClass d) _)    = TyApp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (CPT (CPTClassRef d) _)    = TyApp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (CPT (CPTClassCopy d) _)    = TyApp tyPtr (tycon rawname)+          where rawname = snd (hsClassName d)+        hsrettype (TemplateApp t p _) = TyApp tyPtr (TyApp (tycon rawname) (tycon p))+          where rawname = snd (hsTemplateClassName t)+        hsrettype (TemplateType t) = TyApp tyPtr (TyApp (tycon rawname) (mkTVar (tclass_param t)))+          where rawname = snd (hsTemplateClassName t)+        hsrettype (TemplateParam p) = mkTVar p+
lib/FFICXX/Generate/Type/Module.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Type.Module--- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -12,11 +12,53 @@  module FFICXX.Generate.Type.Module where -data Module = Module { module_name :: String         -                     , module_exports :: [String] -                     } +import           FFICXX.Generate.Type.Class+import           FFICXX.Generate.Type.PackageInterface -mkModuleExports :: Module -> String-mkModuleExports _mod = ""  --- "\n  ( " ++ intercalate "\n  , " (module_exports mod) ++ ")"+newtype Namespace = NS { unNamespace :: String } deriving (Show)++data ClassImportHeader = ClassImportHeader+                       { cihClass :: Class+                       , cihSelfHeader :: HeaderName+                       , cihNamespace :: [Namespace]+                       , cihSelfCpp :: String+                       , cihIncludedHPkgHeadersInH :: [HeaderName]+                       , cihIncludedHPkgHeadersInCPP :: [HeaderName]+                       , cihIncludedCPkgHeaders :: [HeaderName]+                       } deriving (Show)++data ClassModule = ClassModule+                   { cmModule :: String+                   , cmClass :: [Class]+                   , cmCIH :: [ClassImportHeader]+                   , cmImportedModulesHighNonSource :: [String]+                   , cmImportedModulesRaw :: [String]+                   , cmImportedModulesHighSource :: [String]+                   , cmImportedModulesForFFI :: [String]+                   , cmExtraImport :: [String]+                   } deriving (Show)++data TemplateClassModule = TCM { tcmModule :: String+                               , tcmTemplateClasses :: [TemplateClass]+                               , tcmTCIH :: [TemplateClassImportHeader]+                               } deriving (Show)+++data TemplateClassImportHeader = TCIH { tcihTClass :: TemplateClass+                                      , tcihSelfHeader :: HeaderName+                                      } deriving (Show)++data TopLevelImportHeader = TopLevelImportHeader { tihHeaderFileName :: String+                                                 , tihClassDep :: [ClassImportHeader]+                                                 , tihFuncs :: [TopLevelFunction]+                                                 } deriving (Show)++data PackageConfig = PkgConfig { pcfg_classModules :: [ClassModule]+                               , pcfg_classImportHeaders :: [ClassImportHeader]+                               , pcfg_topLevelImportHeader :: TopLevelImportHeader+                               , pcfg_templateClassModules :: [TemplateClassModule]+                               , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader]+                               }++
lib/FFICXX/Generate/Type/PackageInterface.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Type.PackageInterface--- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -27,9 +27,6 @@  instance IsString HeaderName where   fromString = HdrName---  type PackageInterface = HM.HashMap (PackageName, ClassName) HeaderName
lib/FFICXX/Generate/Util.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      : FFICXX.Generate.Util--- Copyright   : (c) 2011-2013 Ian-Woo Kim+-- Copyright   : (c) 2011-2016 Ian-Woo Kim -- -- License     : BSD3 -- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>@@ -13,21 +13,21 @@  module FFICXX.Generate.Util where ----  import           Data.Char  import           Data.List-import           Data.List.Split -import qualified Text.StringTemplate as ST--- --- import           FFICXX.Generate.Type.CType --- +import           Data.List.Split+import           Data.Monoid              ( (<>) )+import           Data.Text                ( Text )+import qualified Data.Text          as T+import qualified Data.Text.Lazy     as TL+import           Data.Text.Template + moduleDirFile :: String -> (String,String) moduleDirFile mname =    let splitted = splitOn "." mname       moddir  = intercalate "/" (init splitted )-      modfile = (last splitted) ++ ".hs" +      modfile = (last splitted) <> ".hs"    in  (moddir, modfile)  hline :: IO ()@@ -45,7 +45,7 @@ firstLower (x:xs) = (toLower x) : xs   conn :: String -> String -> String -> String -conn st x y = x ++ st ++ y  +conn st x y = x <> st <> y    connspace :: String -> String -> String connspace = conn " " @@ -71,7 +71,6 @@ intercalateWith :: (String-> String -> String) -> (a->String) -> [a] -> String intercalateWith  f mapper x    | not (null x) = foldl1 f (map mapper x)--- (foldl1 (\x1 y -> x1 `f` y) . (map mapper)) x     | otherwise    = ""   @@ -81,33 +80,12 @@                       return (foldl1 f ms)   | otherwise = return ""  --- intercalateM :: (Monad m) => String -> [String] -> m String --- intercalateM str = return . foldl1 (\x y-> x ++ str ++ y) +context :: [(Text,String)] -> Context+context assocs x = maybe err (T.pack) . lookup x $ assocs+  where err = error $ "Could not find key: " <> (T.unpack x)          -render :: String -> [(String,String)] -> String        -render tmpl attribs = (ST.render . ST.setManyAttrib attribs . ST.newSTMP) tmpl -   -- flip render1--renderTemplateGroup :: (ST.ToSElem a) => ST.STGroup String -> [(String,a)] -                    -> [Char] -> String -renderTemplateGroup gr attrs tmpl = -    maybe ("template not found: " ++ tmpl)-          (ST.toString . setManyAttribSafer attrs) -          (ST.getStringTemplate tmpl gr)- -setManyAttribSafer :: (ST.Stringable b, ST.ToSElem a) => -                      [(String, a)] -                   -> ST.StringTemplate b -                   -> ST.StringTemplate b-setManyAttribSafer attrs st = -    let mbFoundbadattr = find badTmplVarName . map fst $ attrs -    in maybe (ST.setManyAttrib attrs st) -             (\mbA -> ST.newSTMP . ("setManyAttribSafer, bad template atr: "++) -                      $ mbA)-             mbFoundbadattr -  where badTmplVarName :: String -> Bool -        badTmplVarName t = not . null . filter (not . isAlpha) $ t -+subst :: Text -> Context -> String+subst t c = TL.unpack (substitute t c)
+ lib/FFICXX/Generate/Util/HaskellSrcExts.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+-- |+-- Module      : FFICXX.Generate.Util.HaskellSrcExts+-- Copyright   : (c) 2011-2016 Ian-Woo Kim+--+-- License     : BSD3+-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>+-- Stability   : experimental+-- Portability : GHC+--+-----------------------------------------------------------------------------+++module FFICXX.Generate.Util.HaskellSrcExts where++import           Language.Haskell.Exts+import           Language.Haskell.Exts.SrcLoc++unqual :: String  -> QName+unqual = UnQual . Ident++tycon :: String -> Type+tycon = TyCon . unqual++conDecl :: String -> [Type] -> ConDecl+conDecl n ys = ConDecl (Ident n) ys++recDecl :: String -> [([Name],Type)] -> ConDecl+recDecl n rs = RecDecl (Ident n) rs++app :: String -> String -> Exp+app x y = App (mkVar x) (mkVar y)++mkVar :: String -> Exp+mkVar = Var . unqual++con :: String -> Exp+con = Con . unqual++mkTVar :: String -> Type+mkTVar = TyVar . Ident++mkPVar :: String -> Pat+mkPVar = PVar . Ident++mkPVarSig :: String -> Type -> Pat+mkPVarSig n typ = PatTypeSig noLoc (mkPVar n) typ++pbind :: Pat -> Exp -> Maybe Binds -> Decl+pbind pat e = PatBind noLoc pat (UnGuardedRhs e)++mkTBind :: String -> TyVarBind+mkTBind = UnkindedVar . Ident++mkBind1 :: String -> [Pat] -> Exp -> Maybe Binds -> Decl+mkBind1 n pat rhs mbinds =+  FunBind [ Match noLoc (Ident n) pat Nothing (UnGuardedRhs rhs) mbinds ]++mkFun :: String -> Type -> [Pat] -> Exp -> Maybe Binds -> [Decl]+mkFun fname typ pats rhs mbinds = [mkFunSig fname typ, mkBind1 fname pats rhs mbinds]++mkFunSig :: String -> Type -> Decl+mkFunSig fname typ = TypeSig noLoc [Ident fname] typ++mkClass :: Context -> String -> [TyVarBind] -> [ClassDecl] -> Decl+mkClass ctxt n tbinds cdecls = ClassDecl noLoc ctxt (Ident n) tbinds [] cdecls++mkInstance :: Context -> String -> [Type] -> [InstDecl] -> Decl+mkInstance ctxt n typs idecls = InstDecl noLoc Nothing [] ctxt (unqual n) typs idecls++mkData :: String -> [TyVarBind] -> [QualConDecl] -> [Deriving] -> Decl+mkData n tbinds qdecls derivs  = DataDecl noLoc DataType [] (Ident n) tbinds qdecls derivs++mkNewtype :: String -> [TyVarBind] -> [QualConDecl] -> [Deriving] -> Decl+mkNewtype n tbinds qdecls derivs  = DataDecl noLoc NewType [] (Ident n) tbinds qdecls derivs++mkForImpCcall :: String -> String -> Type -> Decl+mkForImpCcall quote n typ = ForImp noLoc CCall (PlaySafe False) quote (Ident n) typ++mkModule :: String -> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module+mkModule n pragmas idecls decls = Module noLoc (ModuleName n) pragmas Nothing Nothing idecls decls++mkModuleE :: String -> [ModulePragma] -> [ExportSpec] -> [ImportDecl] -> [Decl] -> Module+mkModuleE n pragmas exps idecls decls = Module noLoc (ModuleName n) pragmas Nothing (Just exps) idecls decls++mkImport :: String -> ImportDecl+mkImport m = ImportDecl noLoc (ModuleName m) False False False Nothing Nothing Nothing++mkImportExp :: String -> [String] -> ImportDecl+mkImportExp m lst = ImportDecl noLoc (ModuleName m) False False False Nothing Nothing+                        (Just (False,map (IVar . Ident) lst))++mkImportSrc :: String -> ImportDecl                        +mkImportSrc m = ImportDecl noLoc (ModuleName m) False True False Nothing Nothing Nothing++lang :: [String] -> ModulePragma+lang ns = LanguagePragma noLoc (map Ident ns)++dot :: Exp -> Exp -> Exp+x `dot` y = x `App` mkVar "." `App` y++tyPtr :: Type+tyPtr = tycon "Ptr"++tyForeignPtr :: Type+tyForeignPtr = tycon "ForeignPtr"+
− lib/FFICXX/Paths_fficxx.hs 
@@ -1,6 +0,0 @@-module FFICXX.Paths_fficxx (-  module Paths_fficxx-  ) where--import Paths_fficxx-
sample/snappy-generator/SnappyGen.hs view
@@ -2,6 +2,7 @@ -- import FFICXX.Generate.Builder import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface  snappyclasses = [ ] @@ -71,19 +72,19 @@ headerMap = [ ("Sink"  , ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))             , ("Source", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))             , ("ByteArraySource", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))-	    , ("UncheckedByteArraySink", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))+            , ("UncheckedByteArraySink", ([NS "snappy"], [HdrName "snappy-sinksource.h", HdrName "snappy.h"]))             ]  mycabalattr =      CabalAttr -    { cabalattr_license = Nothing-    , cabalattr_licensefile = Nothing+    { cabalattr_license = Just "BSD3"+    , cabalattr_licensefile = Just "LICENSE"     , cabalattr_extraincludedirs = []     , cabalattr_extralibdirs = []     }  main :: IO () main = do -  simpleBuilder "Snappy" headerMap (mycabal,mycabalattr,myclasses,toplevelfunctions) [ "snappy" ]+  simpleBuilder "Snappy" headerMap (mycabal,mycabalattr,myclasses,toplevelfunctions,[]) [ "snappy" ] []
− template/Cast.hs.st 
@@ -1,14 +0,0 @@-{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeFamilies, -             MultiParamTypeClasses, OverlappingInstances, IncoherentInstances #-}--$castHeader$--import Foreign.Ptr-import Foreign.ForeignPtr (castForeignPtr, newForeignPtr_)-import Foreign.ForeignPtr.Unsafe-import FFICXX.Runtime.Cast-import System.IO.Unsafe--$castImport$--$castBody$
− template/Class.hs-boot.st 
@@ -1,3 +0,0 @@-module $moduleName$ where--$hsBootBody$
− template/Existential.hs.st 
@@ -1,28 +0,0 @@-{-# LANGUAGE TypeFamilies, GADTs, ExistentialQuantification, EmptyDataDecls #-}---- module HROOT.Class.Existential where--$existHeader$-----import Foreign.C            -import Foreign.ForeignPtr---import Foreign.Marshal.Array-import HROOT.TypeCast-import HROOT.Class.TClass.RawType-import HROOT.Class.TClass.Interface-import HROOT.Class.TClass.Cast-import HROOT.Class.TClass.Implementation-import HROOT.Class.TObject.RawType-import HROOT.Class.TObject.Interface-import HROOT.Class.TObject.Cast-import HROOT.Class.TObject.Implementation--$existImport$---- import HROOT.Class.$modname$.Interface--- import HROOT.Class.$modname$.Implementation ()--$existEachBody$--
− template/ExistentialEach.hs.st 
@@ -1,19 +0,0 @@-instance GADTTypeable $mother$ where-  data GADTType $mother$ a where -$GADTbody$-    GADT$mother$Bottom  :: GADTType $mother$ BottomType-  data EGADTType $mother$ = forall a. EGADT$mother$ (GADTType $mother$ a)--cast$mother$ :: Exist $mother$ -> IO (EGADTType $mother$)-cast$mother$ eobj = do -  let obj = $mother$ (get_fptr eobj)-  tclass <- isA obj  -  cname  <- getName tclass-  case cname of -$castbody$-    _         -> return . EGADT$mother$ \$ GADT$mother$Bottom-----
− template/FFI.hsc.st 
@@ -1,19 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}---- module HROOT.Class.FFI where--$ffiHeader$--import Foreign.C            -import Foreign.Ptr---- import HROOT.Class.Interface---- #include "$headerFileName$"--$ffiImport$--$cppInclude$--$hsFunctionBody$-
− template/Implementation.hs.st 
@@ -1,19 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, -             FlexibleInstances, TypeSynonymInstances, EmptyDataDecls, -             OverlappingInstances, IncoherentInstances #-}--$implHeader$--import FFICXX.Runtime.Cast--$implImport$--import Data.Word-import Foreign.C-import Foreign.Ptr -import Foreign.ForeignPtr--import System.IO.Unsafe---$implBody$
− template/Interface.hs.st 
@@ -1,17 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, -             FlexibleInstances, TypeSynonymInstances, -             EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-}---- module HROOT.Class.Interface where--$ifaceHeader$--import Data.Word-import Foreign.C-import Foreign.Ptr-import Foreign.ForeignPtr-import FFICXX.Runtime.Cast--$ifaceImport$--$ifaceBody$
− template/Module.h.st 
@@ -1,18 +0,0 @@-#ifdef __cplusplus-extern "C" { -#endif --#ifndef $typemacro$-#define $typemacro$--#include "$cprefix$Type.h"--$declarationheader$--$declarationbody$--#endif // $typemacro$--#ifdef __cplusplus-}-#endif
− template/Pkg.cabal.st 
@@ -1,42 +0,0 @@-Name:		$pkgname$-Version:	$version$-Synopsis:	$synopsis$-Description: 	$description$-Homepage:       $homepage$-$licenseField$-$licenseFileField$-Author:		$author$-Maintainer: 	$maintainer$-Category:       $category$-Tested-with:    GHC >= 7.6-Build-Type: 	$buildtype$-cabal-version:  >=1.10-Extra-source-files:-$cabalIndentation$CHANGES-$cabalIndentation$Config.hs-$csrcFiles$--$sourcerepository$--Library-  default-language: Haskell2010-  hs-source-dirs: src-  ghc-options:  -Wall -funbox-strict-fields -fno-warn-unused-do-bind -fno-warn-orphans -fno-warn-unused-imports-  ghc-prof-options: -caf-all -auto-all-  cc-options: $ccOptions$-  Build-Depends:      base>4 && < 5, fficxx-runtime >= 0.2 $deps$-  Exposed-Modules:-$exposedModules$-  Other-Modules:-$otherModules$-  extra-lib-dirs: $extralibdirs$-  extra-libraries:    stdc++ $extraLibraries$-  Include-dirs:       csrc $extraincludedirs$-  Install-includes:-$includeFiles$-  C-sources:-$cppFiles$----
− template/Pkg.cpp.st 
@@ -1,38 +0,0 @@-#include <MacroPatternMatch.h>--$header$--using namespace std;-$namespace$--template<class ToType, class FromType>-const ToType* to_const(const FromType* x) {-  return reinterpret_cast<const ToType*>(x);-}--template<class ToType, class FromType>-ToType* to_nonconst(FromType* x) {-  return reinterpret_cast<ToType*>(x);-}--template<class ToType, class FromType>-const ToType& to_constref(const FromType& x) {-  return reinterpret_cast<const ToType&>(x);-}--template<class ToType, class FromType>-ToType& to_nonconstref(FromType& x) {-  return reinterpret_cast<ToType&>(x);-}---#define CHECKPROTECT(x,y) IS_PAREN(IS_ ## x ## _ ## y ## _PROTECTED)--#define TYPECASTMETHOD(cname,mname,oname) \\-  IIF( CHECKPROTECT(cname,mname) ) ( \\-  (to_nonconst<oname,cname ## _t>), \\-  (to_nonconst<cname,cname ## _t>) )--$cppbody$--
− template/Pkg.hs.st 
@@ -1,7 +0,0 @@-module $summarymod$ (-$exportList$ -) where--$importList$--$topLevelDef$
− template/PkgType.h.st 
@@ -1,14 +0,0 @@-#ifdef __cplusplus-extern "C" { -#endif--#ifndef $typemacro$-#define $typemacro$--$typeDeclBody$--#endif // $typemacro$--#ifdef __cplusplus-}-#endif
− template/RawType.hs.st 
@@ -1,10 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface, TypeFamilies, MultiParamTypeClasses, -             FlexibleInstances, TypeSynonymInstances, -             EmptyDataDecls, ExistentialQuantification, ScopedTypeVariables #-}--$rawtypeHeader$--import Foreign.ForeignPtr-import FFICXX.Runtime.Cast  --$rawtypeBody$
− template/classdef.cpp.st 
@@ -1,3 +0,0 @@-#undef ROOT_$classname$_DEFINITION-#define ROOT_$classname$_DEFINITION(Type)  \\-$funcdef$
− template/declbody.h.st 
@@ -1,4 +0,0 @@-#undef ROOT_$classname$_DECLARATION -#define ROOT_$classname$_DECLARATION \\-   $funcdecl$-
− template/funcdecl.h.st 
@@ -1,1 +0,0 @@-$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ )
− template/function.cpp.st 
@@ -1,4 +0,0 @@-$returntype$ Type ## _$funcname$ ( Type ## _p p, $args$ )    \\-{                                                 \\-  $funcbody$                                      \\-}
− template/functionbody.cpp.st 
@@ -1,1 +0,0 @@-to_nonconst<Type,Type ## _t>(p) -> $funcname$ ( $args$ ) ;
− template/module.hs.st 
@@ -1,8 +0,0 @@-module $moduleName$-  (-$exportList$ -  ) where--$importList$--