fficxx 0.3.1 → 0.4
raw patch · 14 files changed
+659/−473 lines, 14 filesdep ~haskell-src-exts
Dependency ranges changed: haskell-src-exts
Files
- fficxx.cabal +2/−2
- lib/FFICXX/Generate/Builder.hs +18/−4
- lib/FFICXX/Generate/Code/Cabal.hs +37/−21
- lib/FFICXX/Generate/Code/Dependency.hs +143/−76
- lib/FFICXX/Generate/Code/HsFFI.hs +4/−4
- lib/FFICXX/Generate/Code/HsFrontEnd.hs +124/−127
- lib/FFICXX/Generate/Code/MethodDef.hs +5/−2
- lib/FFICXX/Generate/ContentMaker.hs +22/−17
- lib/FFICXX/Generate/Type/Class.hs +105/−66
- lib/FFICXX/Generate/Type/Module.hs +2/−0
- lib/FFICXX/Generate/Util/HaskellSrcExts.hs +166/−59
- sample/mysample-generator/MySampleGen.hs +22/−90
- sample/snappy-generator/SnappyGen.hs +4/−4
- sample/snappy-generator/testSnappy.hs +5/−1
fficxx.cabal view
@@ -1,5 +1,5 @@ Name: fficxx-Version: 0.3.1+Version: 0.4 Synopsis: automatic C++ binding generation Description: automatic C++ binding generation License: BSD3@@ -36,7 +36,7 @@ errors, filepath>1, hashable,- haskell-src-exts,+ haskell-src-exts >= 1.18, lens > 3, mtl>2, process,
lib/FFICXX/Generate/Builder.hs view
@@ -57,8 +57,12 @@ workingDir = fficxxconfig_workingDir cfg installDir = fficxxconfig_installBaseDir cfg - pkgconfig@(PkgConfig mods cihs tih tcms _tcihs) =- mkPackageConfig (pkgname, mkClassNSHeaderFromMap (HM.fromList lst)) (classes, toplevelfunctions,templates,extramods)+ pkgconfig@(PkgConfig mods cihs tih tcms _tcihs _ _) =+ mkPackageConfig+ (pkgname, mkClassNSHeaderFromMap (HM.fromList lst))+ (classes, toplevelfunctions,templates,extramods)+ (cabal_additional_c_incs cabal)+ (cabal_additional_c_srcs cabal) hsbootlst = mkHSBOOTCandidateList mods cabalFileName = pkgname <.> "cabal" --@@ -91,6 +95,10 @@ mapM_ (\hdr -> gen (cihSelfCpp hdr) (buildDefMain hdr)) cihs gen (tihHeaderFileName tih <.> "cpp") (buildTopLevelFunctionCppDef tih) --+ putStrLn "additional header/source generation"+ mapM_ (\(AddCInc hdr txt) -> gen hdr txt) (cabal_additional_c_incs cabal)+ mapM_ (\(AddCSrc hdr txt) -> gen hdr txt) (cabal_additional_c_srcs cabal)+ -- putStrLn "RawType.hs file generation" mapM_ (\m -> gen (cmModule m <.> "RawType" <.> "hs") (prettyPrint (buildRawTypeHs m))) mods --@@ -124,7 +132,7 @@ mapM_ (\m -> gen (cmModule m <.> "hs") (prettyPrint (buildModuleHs m))) mods -- putStrLn "summary module generation generation"- gen (summarymodule <.> "hs") (buildPkgHs summarymodule mods tih)+ gen (summarymodule <.> "hs") (buildPkgHs summarymodule (mods,tcms) tih) -- putStrLn "copying" touch (workingDir </> "LICENSE")@@ -161,7 +169,7 @@ copyCppFiles :: FilePath -> FilePath -> String -> PackageConfig -> IO ()-copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs) = do +copyCppFiles wdir ddir cprefix (PkgConfig _ cihs tih _ tcihs acincs acsrcs) = do let thfile = cprefix <> "Type.h" tlhfile = tihHeaderFileName tih <.> "h" tlcppfile = tihHeaderFileName tih <.> "cpp"@@ -179,6 +187,12 @@ forM_ tcihs $ \header-> do let hfile = unHdrName (tcihSelfHeader header) copyFileWithMD5Check (wdir </> hfile) (ddir </> hfile) ++ forM_ acincs $ \(AddCInc header _) -> + copyFileWithMD5Check (wdir </> header) (ddir </> header)++ forM_ acsrcs $ \(AddCSrc csrc _) -> + copyFileWithMD5Check (wdir </> csrc) (ddir </> csrc) moduleFileCopy :: FilePath -> FilePath -> FilePath -> IO ()
lib/FFICXX/Generate/Code/Cabal.hs view
@@ -29,18 +29,12 @@ 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) =+-- for source distribution+genCsrcFiles :: (TopLevelImportHeader,[ClassModule])+ -> [AddCInc]+ -> [AddCSrc]+ -> String+genCsrcFiles (tih,cmods) acincs acsrcs = let indent = cabalIndentation selfheaders' = do x <- cmods@@ -54,24 +48,44 @@ selfcpp = nub selfcpp' tlh = tihHeaderFileName tih <.> "h" tlcpp = tihHeaderFileName tih <.> "cpp"- includeFileStrsWithCsrc = map (\x->indent<>"csrc"</> x) + 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) + ++ map (\(AddCInc hdr _) -> hdr) acincs+ cppFilesWithCsrc = map (\x->indent<>"csrc"</>x) $ (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)+ ++ map (\(AddCSrc src _) -> src) acsrcs+ in unlines (includeFileStrsWithCsrc <> cppFilesWithCsrc) -genCppFiles :: (TopLevelImportHeader,[ClassModule]) -> String -genCppFiles (tih,cmods) = ++-- for library+genIncludeFiles :: String -- ^ package name + -> ([ClassImportHeader],[TemplateClassImportHeader])+ -> [AddCInc]+ -> String+genIncludeFiles pkgname (cih,tcih) acincs = let indent = cabalIndentation + selfheaders = map cihSelfHeader cih <> map tcihSelfHeader tcih+ includeFileStrs = map ((indent<>).unHdrName) (selfheaders ++ map (\(AddCInc hdr _) -> HdrName hdr) acincs)+ in unlines ((indent<>pkgname<>"Type.h") : includeFileStrs)+++-- for library+genCppFiles :: (TopLevelImportHeader,[ClassModule])+ -> [AddCSrc]+ -> String +genCppFiles (tih,cmods) acsrcs = + let indent = cabalIndentation selfcpp' = do x <- cmods y <- cmCIH x return (cihSelfCpp y) selfcpp = nub selfcpp' tlcpp = tihHeaderFileName tih <.> "cpp"- cppFileStrs = map (\x->indent<> "csrc" </> x) + cppFileStrs = map (\x->indent<> "csrc" </> x) $ (if (null.tihFuncs) tih then selfcpp else tlcpp:selfcpp)+ ++ map (\(AddCSrc src _) -> src) acsrcs in unlines cppFileStrs @@ -140,7 +154,7 @@ -- | buildCabalFile :: (Cabal, CabalAttr) -> String- -> PackageConfig -- (TopLevelImportHeader,[ClassModule],[TemplateClassModule])+ -> PackageConfig -> [String] -- ^ extra libs -> FilePath -> IO ()@@ -150,6 +164,8 @@ cih = pcfg_classImportHeaders pkgconfig tmods = pcfg_templateClassModules pkgconfig tcih = pcfg_templateClassImportHeaders pkgconfig+ acincs = pcfg_additional_c_incs pkgconfig+ acsrcs = pcfg_additional_c_srcs pkgconfig extrafiles = cabalattr_extrafiles cabalattr txt = subst cabalTemplate (context ([ ("licenseField", "license: " <> license)@@ -169,9 +185,9 @@ , ("ccOptions","-std=c++14") , ("deps", "") , ("extraFiles", concatMap (\x -> cabalIndentation <> x <> "\n") extrafiles)- , ("csrcFiles", genCsrcFiles (tih,classmodules))- , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) (cih,tcih) )- , ("cppFiles", genCppFiles (tih,classmodules))+ , ("csrcFiles", genCsrcFiles (tih,classmodules) acincs acsrcs)+ , ("includeFiles", genIncludeFiles (cabal_pkgname cabal) (cih,tcih) acincs)+ , ("cppFiles", genCppFiles (tih,classmodules) acsrcs) , ("exposedModules", genExposedModules summarymodule (classmodules,tmods)) , ("otherModules", genOtherModules classmodules) , ("extralibdirs", intercalate ", " $ cabalattr_extralibdirs cabalattr)
lib/FFICXX/Generate/Code/Dependency.hs view
@@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.Dependency--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2017 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -14,6 +14,25 @@ module FFICXX.Generate.Code.Dependency where +--+-- fficxx generates one module per one C++ class, and C++ class depends on other classes,+-- so we need to import other modules corresponding to C++ classes in the dependency list.+-- Calculating the import list from dependency graph is what this module does.++-- Previously, we have only `Class` type, but added `TemplateClass` recently. Therefore+-- we have to calculate dependency graph for both types of classes. So we needed to change+-- `Class` to `Either TemplateClass Class` in many of routines that calculates module import+-- list.++-- `Dep4Func` contains a list of classes (both ordinary and template types) that is needed+-- for the definition of a member function.+-- The goal of `extractClassDep...` functions are to extract Dep4Func, and from the definition+-- of a class or a template class, we get a list of `Dep4Func`s and then we deduplicate the+-- dependency class list and finally get the import list for the module corresponding to+-- a given class. +-- ++import Data.Either ( rights ) import Data.Function ( on ) import qualified Data.HashMap.Strict as HM import Data.List @@ -24,62 +43,37 @@ import FFICXX.Generate.Type.Class import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface+--+import Debug.Trace --- | -mkPkgHeaderFileName ::Class -> HeaderName-mkPkgHeaderFileName c = - HdrName ((cabal_cheaderprefix.class_cabal) c <> class_name c <.> "h")---- | -mkPkgCppFileName ::Class -> String -mkPkgCppFileName c = - (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-- +-- utility functions --- | -mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]-mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . mkModuleDepCpp +getclassname = either tclass_name class_name +getcabal = either tclass_cabal class_cabal --- | -mkCIH :: (Class->([Namespace],[HeaderName])) -- ^ (mk namespace and include headers) - -> Class - -> ClassImportHeader-mkCIH mkNSandIncHdrs c = ClassImportHeader c - (mkPkgHeaderFileName c) - ((fst . mkNSandIncHdrs) c)- (mkPkgCppFileName c) - (mkPkgIncludeHeadersInH c) - (mkPkgIncludeHeadersInCPP c)- ((snd . mkNSandIncHdrs) c)+getparents = either (const []) (map Right . class_parents) +getmodulebase = either getTClassModuleBase getClassModuleBase -- |-extractClassFromType :: Types -> Maybe Class+extractClassFromType :: Types -> Maybe (Either TemplateClass Class) 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 (CPT (CPTClass c) _) = Just (Right c)+extractClassFromType (CPT (CPTClassRef c) _) = Just (Right c)+extractClassFromType (CPT (CPTClassCopy c) _) = Just (Right c)+extractClassFromType (TemplateApp t _ _) = Just (Left t)+extractClassFromType (TemplateAppRef t _ _) = Just (Left t)+extractClassFromType (TemplateType t) = Just (Left t) extractClassFromType (TemplateParam _) = Nothing -- | class dependency for a given function -data Dep4Func = Dep4Func { returnDependency :: Maybe Class - , argumentDependency :: [Class] }+data Dep4Func = Dep4Func { returnDependency :: Maybe (Either TemplateClass Class)+ , argumentDependency :: [(Either TemplateClass Class)] } -- | @@ -94,6 +88,15 @@ extractClassDep (Destructor _) = Dep4Func Nothing [] ++extractClassDepForTmplFun :: TemplateFunction -> Dep4Func +extractClassDepForTmplFun (TFun ret _ _ args _) = + Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)+extractClassDepForTmplFun (TFunNew args) =+ Dep4Func Nothing (mapMaybe (extractClassFromType.fst) args)+extractClassDepForTmplFun TFunDelete = Dep4Func Nothing [] ++ extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func extractClassDepForTopLevelFunction f = Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)@@ -104,52 +107,77 @@ TopLevelFunction {..} -> toplevelfunc_args TopLevelVariable {..} -> [] + -- | -mkModuleDepRaw :: Class -> [Class] -mkModuleDepRaw c = (nub . filter (/= c) . mapMaybe (returnDependency.extractClassDep) . class_funcs) c+mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class] +mkModuleDepRaw x@(Right c)+ = (nub . filter (/= x) . mapMaybe (returnDependency.extractClassDep) . class_funcs) c+mkModuleDepRaw x@(Left t)+ = (nub . filter (/= x) . mapMaybe (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t -- | -mkModuleDepHighNonSource :: Class -> [Class] -mkModuleDepHighNonSource c = +mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class] +mkModuleDepHighNonSource y@(Right c) = let fs = class_funcs c - 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 + pkgname = (cabal_pkgname . class_cabal) c+ extclasses = (filter (\x-> x /= y && ((/= pkgname) . cabal_pkgname . getcabal) x) . concatMap (argumentDependency.extractClassDep)) fs+ parents = map Right (class_parents c) in nub (parents <> extclasses) +mkModuleDepHighNonSource y@(Left t) = + let fs = tclass_funcs t + pkgname = (cabal_pkgname . tclass_cabal) t + extclasses = (filter (\x-> x /= y && ((/= pkgname) . cabal_pkgname . getcabal) x) . concatMap (argumentDependency.extractClassDepForTmplFun)) fs+ -- parents = class_parents c + in nub extclasses -- | -mkModuleDepHighSource :: Class -> [Class] -mkModuleDepHighSource c = +mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class] +mkModuleDepHighSource y@(Right c) = let fs = class_funcs c pkgname = (cabal_pkgname . class_cabal) c - in nub . filter (\x-> x /= c && not (x `elem` class_parents c) && (((== pkgname) . cabal_pkgname . class_cabal) x)) . concatMap (argumentDependency.extractClassDep) $ fs+ in nub . filter (\x-> x /= y && not (x `elem` getparents y) && (((== pkgname) . cabal_pkgname . getcabal) x)) . concatMap (argumentDependency.extractClassDep) $ fs+mkModuleDepHighSource y@(Left t) = + let fs = tclass_funcs t+ pkgname = (cabal_pkgname . tclass_cabal) t+ in nub . filter (\x-> x /= y && not (x `elem` getparents y) && (((== pkgname) . cabal_pkgname . getcabal) x)) . concatMap (argumentDependency.extractClassDepForTmplFun) $ fs -- | -mkModuleDepCpp :: Class -> [Class] -mkModuleDepCpp c = +mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class] +mkModuleDepCpp y@(Right c) = let fs = class_funcs c - in nub . filter (/= c) $ + in nub . filter (/= y) $ mapMaybe (returnDependency.extractClassDep) fs <> concatMap (argumentDependency.extractClassDep) fs- <> (class_parents c) + <> getparents y+mkModuleDepCpp y@(Left t) = + let fs = tclass_funcs t+ in nub . filter (/= y) $ + mapMaybe (returnDependency.extractClassDepForTmplFun) fs + <> concatMap (argumentDependency.extractClassDepForTmplFun) fs+ <> getparents y -- | -mkModuleDepFFI4One :: Class -> [Class] -mkModuleDepFFI4One c = +mkModuleDepFFI4One :: Either TemplateClass Class -> [Either TemplateClass Class] +mkModuleDepFFI4One (Right c) = let fs = class_funcs c - in (<>) <$> mapMaybe (returnDependency.extractClassDep) - <*> concatMap (argumentDependency.extractClassDep) - $ fs+ in mapMaybe (returnDependency.extractClassDep) fs <> concatMap (argumentDependency.extractClassDep) fs +mkModuleDepFFI4One (Left t) = + let fs = tclass_funcs t + in mapMaybe (returnDependency.extractClassDepForTmplFun) fs <>+ concatMap (argumentDependency.extractClassDepForTmplFun) fs + -- | -mkModuleDepFFI :: Class -> [Class] -mkModuleDepFFI c = - let ps = class_allparents c - alldeps' = (concatMap mkModuleDepFFI4One ps) <> mkModuleDepFFI4One c- in nub (filter (/= c) alldeps')- +mkModuleDepFFI :: Either TemplateClass Class -> [Either TemplateClass Class] +mkModuleDepFFI y@(Right c) = + let ps = map Right (class_allparents c)+ alldeps' = (concatMap mkModuleDepFFI4One ps) <> mkModuleDepFFI4One y+ in nub (filter (/= y) alldeps')+mkModuleDepFFI y@(Left t) = [] ++ mkClassModule :: (Class->([Namespace],[HeaderName])) -> [(String,[String])] -> Class @@ -158,10 +186,10 @@ 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+ where highs_nonsource = (map getmodulebase . mkModuleDepHighNonSource) (Right c)+ raws = (map getmodulebase . mkModuleDepRaw) (Right c)+ highs_source = (map getmodulebase . mkModuleDepHighSource) (Right c)+ ffis = (map getmodulebase . mkModuleDepFFI) (Right c) extraimports = fromMaybe [] (lookup (class_name c) extra) @@ -176,24 +204,63 @@ mkPackageConfig :: (String,Class->([Namespace],[HeaderName])) -- ^ (package name,mkIncludeHeaders)- -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])]) + -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])])+ -> [AddCInc]+ -> [AddCSrc] -> PackageConfig-mkPackageConfig (pkgname,mkNS_IncHdrs) (cs,fs,ts,extra) = +mkPackageConfig (pkgname,mkNS_IncHdrs) (cs,fs,ts,extra) acincs acsrcs = 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` getclassname) (tl_cs1 <> tl_cs2) tl_cihs = catMaybes $ - foldr (\c acc-> (find (\x -> (class_name . cihClass) x == class_name c) cihs):acc) [] tl_cs + foldr (\c acc-> (find (\x -> (class_name . cihClass) x == getclassname c) cihs):acc) [] tl_cs -- tih = TopLevelImportHeader (pkgname <> "TopLevel") tl_cihs fs tcms = map mkTCM ts tcihs = concatMap tcmTCIH tcms- in PkgConfig ms cihs tih tcms tcihs+ in PkgConfig ms cihs tih tcms tcihs acincs acsrcs mkHSBOOTCandidateList :: [ClassModule] -> [String] mkHSBOOTCandidateList ms = nub (concatMap cmImportedModulesHighSource ms)++-- | +mkPkgHeaderFileName ::Class -> HeaderName+mkPkgHeaderFileName c = + HdrName ((cabal_cheaderprefix.class_cabal) c <> class_name c <.> "h")++-- | +mkPkgCppFileName ::Class -> String +mkPkgCppFileName c = + (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 . getcabal) . mkModuleDepCpp) (Right c)+ extheaders = nub . map ((<>"Type.h") . cabal_pkgname . getcabal) $ extclasses + in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders++ ++-- | +mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]+mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right+++-- | +mkCIH :: (Class->([Namespace],[HeaderName])) -- ^ (mk namespace and include headers) + -> Class + -> ClassImportHeader+mkCIH mkNSandIncHdrs c = ClassImportHeader c + (mkPkgHeaderFileName c) + ((fst . mkNSandIncHdrs) c)+ (mkPkgCppFileName c) + (mkPkgIncludeHeadersInH c) + (mkPkgIncludeHeadersInCPP c)+ ((snd . mkNSandIncHdrs) c)
lib/FFICXX/Generate/Code/HsFFI.hs view
@@ -4,7 +4,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFFI--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2017 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -26,7 +26,7 @@ import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface -genHsFFI :: ClassImportHeader -> [Decl]+genHsFFI :: ClassImportHeader -> [Decl ()] genHsFFI header = let c = cihClass header h = cihSelfHeader header@@ -37,7 +37,7 @@ -------- -hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe Decl+hsFFIClassFunc :: HeaderName -> Class -> Function -> Maybe (Decl ()) hsFFIClassFunc headerfilename c f = if isAbstractClass c then Nothing@@ -52,7 +52,7 @@ -- for top level function -- ---------------------------- -genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl+genTopLevelFuncFFI :: TopLevelImportHeader -> TopLevelFunction -> Decl () genTopLevelFuncFFI header tfn = mkForImpCcall (hfilename <> " TopLevel_" <> fname) cfname typ where (fname,args,ret) = case tfn of
lib/FFICXX/Generate/Code/HsFrontEnd.hs view
@@ -5,7 +5,7 @@ ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Code.HsFrontEnd--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2017 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -20,6 +20,10 @@ import Control.Monad.Reader import Data.List import Data.Monoid ( (<>) )+import Language.Haskell.Exts.Build ( app, binds, doE, letE, letStmt+ , name, pApp+ , qualStmt, strE, tuple+ ) import Language.Haskell.Exts.Syntax ( Asst(..), Binds(..), Boxed(..), Bracket(..) , ClassDecl(..), DataOrNew(..), Decl(..) , Exp(..), ExportSpec(..)@@ -28,7 +32,7 @@ , QualConDecl(..), Stmt(..) , Type(..), TyVarBind (..) )-import Language.Haskell.Exts.SrcLoc ( noLoc )+-- import Language.Haskell.Exts.SrcLoc ( noLoc ) import System.FilePath ((<.>)) -- import FFICXX.Generate.Type.Class@@ -59,25 +63,25 @@ | otherwise = str -genHsFrontDecl :: Class -> Reader AnnotateMap Decl+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 + body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c return cdecl ------------------- -genHsFrontInst :: Class -> Class -> [Decl]+genHsFrontInst :: Class -> Class -> [Decl ()] genHsFrontInst parent child | (not.isAbstractClass) child = - let idecl = mkInstance [] (typeclassName parent) [convertCpp2HS (Just child) SelfType] body+ let idecl = mkInstance cxEmpty (typeclassName parent) [convertCpp2HS (Just child) SelfType] body defn f = mkBind1 (hsFuncName child f) [] rhs Nothing - where rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))- body = map (InsDecl . defn) . virtualFuncs . class_funcs $ parent+ where rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))+ body = map (insDecl . defn) . virtualFuncs . class_funcs $ parent in [idecl] | otherwise = [] @@ -87,7 +91,7 @@ --------------------- genHsFrontInstNew :: Class -- ^ only concrete class - -> Reader AnnotateMap [Decl]+ -> Reader AnnotateMap [Decl ()] genHsFrontInstNew c = do -- amap <- ask let fs = filter isNewFunc (class_funcs c)@@ -96,140 +100,134 @@ -- 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))+ rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) in mkFun (constructorName c) (functionSignature c f) [] rhs Nothing -genHsFrontInstNonVirtual :: Class -> [Decl]+genHsFrontInstNonVirtual :: Class -> [Decl ()] genHsFrontInstNonVirtual c = flip concatMap nonvirtualFuncs $ \f -> - let rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+ let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c) ----- -genHsFrontInstStatic :: Class -> [Decl]+genHsFrontInstStatic :: Class -> [Decl ()] genHsFrontInstStatic c = flip concatMap (staticFuncs (class_funcs c)) $ \f ->- let rhs = App (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))+ let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f)) in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing ----- -castBody :: [InstDecl]+castBody :: [InstDecl ()] castBody =- [ InsDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (App (mkVar "f") (App (mkVar "castPtr") (App (mkVar "get_fptr") (mkVar "x")))) Nothing)- , InsDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (App (mkVar "f") (App (mkVar "cast_fptr_to_obj") (App (mkVar "castPtr") (mkVar "x")))) Nothing)+ [ insDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "castPtr") (app (mkVar "get_fptr") (mkVar "x")))) Nothing)+ , insDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "cast_fptr_to_obj") (app (mkVar "castPtr") (mkVar "x")))) Nothing) ] -genHsFrontInstCastable :: Class -> Maybe Decl+genHsFrontInstCastable :: Class -> Maybe (Decl ()) genHsFrontInstCastable c | (not.isAbstractClass) c = let iname = typeclassName c (_,rname) = hsClassName c a = mkTVar "a"- ctxt = [ ClassA (unqual iname) [a], ClassA (unqual "FPtr") [a] ]- in Just (mkInstance ctxt "Castable" [a,TyApp tyPtr (tycon rname)] castBody)+ ctxt = cxTuple [ classA (unqual iname) [a], classA (unqual "FPtr") [a] ]+ in Just (mkInstance ctxt "Castable" [a,tyapp tyPtr (tycon rname)] castBody) | otherwise = Nothing -genHsFrontInstCastableSelf :: Class -> Maybe Decl+genHsFrontInstCastableSelf :: Class -> Maybe (Decl ()) genHsFrontInstCastableSelf c | (not.isAbstractClass) c = let (cname,rname) = hsClassName c- in Just (mkInstance [] "Castable" [tycon cname, TyApp tyPtr (tycon rname)] castBody)+ in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody) | otherwise = Nothing -------------------------- -hsClassRawType :: Class -> [Decl]+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)+ [ mkData rawname [] [] Nothing+ , mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv+ , mkInstance cxEmpty "FPtr" [hightype]+ [ insType (tyapp (tycon "Raw") hightype) rawtype+ , insDecl (mkBind1 "get_fptr" [pApp (name highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)+ , insDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing) ] ] where (highname,rawname) = hsClassName c hightype = tycon highname rawtype = tycon rawname- derivs = [(unqual "Eq",[]),(unqual "Ord",[]),(unqual "Show",[])]+ mderiv = Just (mkDeriving [i_eq,i_ord,i_show])+ where i_eq = irule Nothing Nothing (ihcon (unqual "Eq"))+ i_ord = irule Nothing Nothing (ihcon (unqual "Ord"))+ i_show = irule Nothing Nothing (ihcon (unqual "Show")) ------------ -- upcast -- ------------ -genHsFrontUpcastClass :: Class -> [Decl]+genHsFrontUpcastClass :: 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_bind = unkindedVar (name "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")+ typ = tyForall (Just [a_bind])+ (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))+ (tyfun a_tvar hightype)+ rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing+ , pbind (mkPVarSig "fh2" (tyapp tyPtr rawtype))+ (app (mkVar "castPtr") (mkVar "fh")) Nothing+ ]+ (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") -------------- -- downcast -- -------------- -genHsFrontDowncastClass :: Class -> [Decl]+genHsFrontDowncastClass :: 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_bind = unkindedVar (name "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")+ typ = tyForall (Just [a_bind])+ (Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))+ (tyfun hightype a_tvar)+ rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing+ , pbind (mkPVar "fh2") (app (mkVar "castPtr") (mkVar "fh")) Nothing+ ] + (mkVar "cast_fptr_to_obj" `app` mkVar "fh2") ------------------------ -- Top Level Function -- ------------------------ -genTopLevelFuncDef :: TopLevelFunction -> [Decl]+genTopLevelFuncDef :: 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)+ (typs,assts) = extractArgRetTypes Nothing False (toplevelfunc_args,toplevelfunc_ret)+ sig = tyForall Nothing (Just (cxTuple assts)) (foldr1 tyfun typs) xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull" cfname = "c_" <> toLowers fname - rhs = App (mkVar xformerstr) (mkVar cfname)+ 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)+ sig = tyapp (tycon "IO") rtyp+ rhs = app (mkVar "xformnull") (mkVar cfname) in mkFun fname sig [] rhs Nothing @@ -238,45 +236,45 @@ -- Export -- ------------ -genExport :: Class -> [ExportSpec]+genExport :: Class -> [ExportSpec ()] genExport c = let espec n = if null . (filter isVirtualFunc) $ (class_funcs c) - then EAbs NoNamespace (unqual n)- else EThingAll (unqual n)+ then eabs nonamespace (unqual n)+ else ethingall (unqual n) in if isAbstractClass c then [ espec (typeclassName c) ]- else [ EThingAll (unqual ((fst.hsClassName) c))+ else [ ethingall (unqual ((fst.hsClassName) c)) , espec (typeclassName c)- , EVar (unqual ("upcast" <> (fst.hsClassName) c))- , EVar (unqual ("downcast" <> (fst.hsClassName) c)) ]+ , evar (unqual ("upcast" <> (fst.hsClassName) c))+ , evar (unqual ("downcast" <> (fst.hsClassName) c)) ] <> genExportConstructorAndNonvirtual c <> genExportStatic c -- | constructor and non-virtual function -genExportConstructorAndNonvirtual :: Class -> [ExportSpec]-genExportConstructorAndNonvirtual c = map (EVar . unqual) fns+genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()]+genExportConstructorAndNonvirtual c = map (evar . unqual) fns where fs = class_funcs c fns = map (aliasedFuncName c) (constructorFuncs fs <> nonVirtualNotNewFuncs fs) -- | staic function export list -genExportStatic :: Class -> [ExportSpec]-genExportStatic c = map (EVar . unqual) fns+genExportStatic :: Class -> [ExportSpec ()]+genExportStatic c = map (evar . unqual) fns where fs = class_funcs c fns = map (aliasedFuncName c) (staticFuncs fs) -genExtraImport :: ClassModule -> [ImportDecl]+genExtraImport :: ClassModule -> [ImportDecl ()] genExtraImport cm = map mkImport (cmExtraImport cm) -genImportInModule :: [Class] -> [ImportDecl]+genImportInModule :: [Class] -> [ImportDecl ()] genImportInModule = concatMap (\x -> map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"]) -genImportInFFI :: ClassModule -> [ImportDecl]+genImportInFFI :: ClassModule -> [ImportDecl ()] genImportInFFI = map (\x->mkImport (x <.> "RawType")) . cmImportedModulesForFFI -genImportInInterface :: ClassModule -> [ImportDecl]+genImportInInterface :: ClassModule -> [ImportDecl ()] genImportInInterface m = let modlstraw = cmImportedModulesRaw m modlstparent = cmImportedModulesHighNonSource m @@ -287,12 +285,12 @@ <> map (\x -> mkImportSrc (x<.>"Interface")) modlsthigh -- |-genImportInCast :: ClassModule -> [ImportDecl]+genImportInCast :: ClassModule -> [ImportDecl ()] genImportInCast m = [ mkImport (cmModule m <.> "RawType") , mkImport (cmModule m <.> "Interface") ] -- | -genImportInImplementation :: ClassModule -> [ImportDecl]+genImportInImplementation :: ClassModule -> [ImportDecl ()] genImportInImplementation m = let modlstraw' = cmImportedModulesForFFI m modlsthigh = nub $ map getClassModuleBase $ concatMap class_allparents (cmClass m)@@ -305,34 +303,34 @@ <> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlsthigh -genTmplInterface :: TemplateClass -> [Decl]+genTmplInterface :: TemplateClass -> [Decl ()] genTmplInterface t =- [ mkData rname [mkTBind tp] [] []+ [ mkData rname [mkTBind tp] [] Nothing , 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+ [ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing+ , mkClass cxEmpty (typeclassNameT t) [mkTBind tp] methods+ , mkInstance cxEmpty "FPtr" [ hightype ] fptrbody+ , mkInstance cxEmpty "Castable" [ hightype, tyapp tyPtr rawtype ] castBody ] where (hname,rname) = hsTemplateClassName t tp = tclass_param t fs = tclass_funcs t- rawtype = TyApp (tycon rname) (mkTVar tp)- hightype = TyApp (tycon hname) (mkTVar tp)+ 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)+ methods = map (clsDecl . sigdecl) fs+ fptrbody = [ insType (tyapp (tycon "Raw") hightype) rawtype+ , insDecl (mkBind1 "get_fptr" [pApp (name hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)+ , insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing) ] -genTmplImplementation :: TemplateClass -> [Decl]+genTmplImplementation :: TemplateClass -> [Decl ()] genTmplImplementation t = concatMap gen (tclass_funcs t) where- gen f = mkFun nh sig [p "nty", p "ncty"] rhs (Just binds)+ gen f = mkFun nh sig [p "nty", p "ncty"] rhs (Just bstmts) where nh = case f of TFun {..} -> "t_" <> tfun_name TFunNew {..} -> "t_" <> "new" <> tclass_name t@@ -341,60 +339,59 @@ TFun {..} -> tfun_name TFunNew {..} -> "new" TFunDelete -> "delete" - sig = tycon "Name" `TyFun` (tycon "String" `TyFun` tycon "ExpQ")+ 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"])+ lit = strE (prefix<>"_"<>nc<>"_")+ lam = lambda [p "n"] ( lit `app` v "<>" `app` v "n") + rhs = app (v "mkTFunc") (tuple [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')))+ bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]+ (letE [ pbind (p tp) (v "return" `app` (con "ConT" `app` v "n")) Nothing ]+ (bracketExp (typeBracket sig'))) Nothing ] -genTmplInstance :: TemplateClass -> [TemplateFunction] -> [Decl]+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"))))+ sig = tycon "Name" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tylist (tycon "Dec")))) nfs = zip ([1..] :: [Int]) fs- rhs = Do (map genstmt nfs <> [LetStmt (lststmt nfs), Qualifier retstmt])+ rhs = doE (map genstmt nfs <> [letStmt (lststmt nfs), qualStmt retstmt]) - 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,TFun {..}) = generator (p ("f"<>show n))+ (v "mkMember" `app` strE 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,TFunNew {..}) = generator (p ("f"<>show n)) + (v "mkNew" `app` strE ("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"+ genstmt (n,TFunDelete) = generator (p ("f"<>show n)) + (v "mkDelete" `app` strE ("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 ]+ lststmt xs = [ pbind (p "lst") (list (map (v . (\n->"f"<>show n) . fst) xs)) 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` list [ v "mkInstance"+ `app` list []+ `app` (con "AppT"+ `app` (v "con" `app` strE (typeclassNameT t))+ `app` (con "ConT" `app` (v "n")) )- `App` (v "lst")+ `app` (v "lst") ]
lib/FFICXX/Generate/Code/MethodDef.hs view
@@ -35,12 +35,15 @@ CPT (CPTClass c') _ -> "return to_nonconst<"<>str<>"_t,"<>str <>">(("<>str<>"*)"<>callstr<>");" where str = class_name c'- CPT (CPTClassRef _c') _ -> "return ((*)"<>callstr<>");"+ CPT (CPTClassRef c') _ -> "return to_nonconst<"<>str<>"_t,"<>str+ <>">(&("<>callstr<>"));"+ where str = class_name c' CPT (CPTClassCopy c') _ -> "return to_nonconst<"<>str<>"_t,"<>str <>">(new "<>str<>"("<>callstr<>"));" where str = class_name c' - TemplateApp _ _ _ -> "return (" <> callstr <> ");" + TemplateApp _ _ _ -> "return (" <> callstr <> ");"+ TemplateAppRef _ _ _ -> "return (&(" <> callstr <> "));" TemplateType _ -> error "returnCpp: TemplateType" TemplateParam _ -> if b then "return (" <> callstr <> ");"
lib/FFICXX/Generate/ContentMaker.hs view
@@ -255,7 +255,7 @@ -- | -buildFFIHsc :: ClassModule -> Module+buildFFIHsc :: ClassModule -> Module () buildFFIHsc m = mkModule (mname <.> "FFI") [lang ["ForeignFunctionInterface"]] ffiImports hscBody where mname = cmModule m headers = cmCIH m@@ -266,7 +266,7 @@ -- | -buildRawTypeHs :: ClassModule -> Module+buildRawTypeHs :: ClassModule -> Module () buildRawTypeHs m = mkModule (cmModule m <.> "RawType") [lang [ "ForeignFunctionInterface", "TypeFamilies", "MultiParamTypeClasses" , "FlexibleInstances", "TypeSynonymInstances"@@ -279,7 +279,7 @@ rawtypeBody = concatMap hsClassRawType . filter (not.isAbstractClass) . cmClass $ m -- | -buildInterfaceHs :: AnnotateMap -> ClassModule -> Module +buildInterfaceHs :: AnnotateMap -> ClassModule -> Module () buildInterfaceHs amap m = mkModule (cmModule m <.> "Interface") [lang [ "EmptyDataDecls", "ExistentialQuantification" , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface"@@ -301,7 +301,7 @@ <> (concatMap genHsFrontDowncastClass . filter (not.isAbstractClass)) classes -- | -buildCastHs :: ClassModule -> Module+buildCastHs :: ClassModule -> Module () buildCastHs m = mkModule (cmModule m <.> "Cast") [ lang [ "FlexibleInstances", "FlexibleContexts", "TypeFamilies" , "MultiParamTypeClasses", "OverlappingInstances", "IncoherentInstances" ] ]@@ -315,7 +315,7 @@ <> mapMaybe genHsFrontInstCastableSelf classes -- | -buildImplementationHs :: AnnotateMap -> ClassModule -> Module+buildImplementationHs :: AnnotateMap -> ClassModule -> Module () buildImplementationHs amap m = mkModule (cmModule m <.> "Implementation") [ lang [ "EmptyDataDecls" , "FlexibleContexts", "FlexibleInstances", "ForeignFunctionInterface"@@ -333,7 +333,7 @@ , mkImport "System.IO.Unsafe" ] <> genImportInImplementation m <> genExtraImport m- f :: Class -> [Decl]+ f :: Class -> [Decl ()] f y = concatMap (flip genHsFrontInst y) (y:class_allparents y) implBody = concatMap f classes@@ -341,7 +341,7 @@ <> concatMap genHsFrontInstNonVirtual classes <> concatMap genHsFrontInstStatic classes -buildTemplateHs :: TemplateClassModule -> Module+buildTemplateHs :: TemplateClassModule -> Module () buildTemplateHs m = mkModule (tcmModule m <.> "Template") [lang [ "EmptyDataDecls", "FlexibleInstances", "MultiParamTypeClasses" , "TypeFamilies"] ]@@ -353,7 +353,7 @@ where ts = tcmTemplateClasses m body = concatMap genTmplInterface ts -buildTHHs :: TemplateClassModule -> Module+buildTHHs :: TemplateClassModule -> Module () buildTHHs m = mkModule (tcmModule m <.> "TH") [lang ["TemplateHaskell"] ] ([ mkImport "Data.Char"@@ -371,18 +371,18 @@ <> concatMap (\t -> genTmplInstance t (tclass_funcs t)) ts -- | -buildInterfaceHSBOOT :: String -> Module+buildInterfaceHSBOOT :: String -> Module () buildInterfaceHSBOOT mname = mkModule (mname <.> "Interface") [] [] hsbootBody where cname = last (splitOn "." mname)- hsbootBody = [ mkClass [] ('I':cname) [mkTBind "a"] [] ]+ hsbootBody = [ mkClass cxEmpty ('I':cname) [mkTBind "a"] [] ] -- | -buildModuleHs :: ClassModule -> Module+buildModuleHs :: ClassModule -> Module () buildModuleHs m = mkModuleE (cmModule m) [] (concatMap genExport (cmClass m)) (genImportInModule (cmClass m)) [] -- | -buildPkgHs :: String -> [ClassModule] -> TopLevelImportHeader -> String -buildPkgHs modname mods tih = +buildPkgHs :: String -> ([ClassModule],[TemplateClassModule]) -> TopLevelImportHeader -> String +buildPkgHs modname (mods,tmods) tih = let tfns = tihFuncs tih exportListStr = intercalateWith (conn "\n, ") ((\x->"module " <> x).cmModule) mods <> if null tfns @@ -391,17 +391,22 @@ 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`+ 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)+ `connRet`+ intercalateWith connRet+ ((\x->"import " <> x <> ".Template").tcmModule) tmods topLevelDefStr = intercalate "\n" (map (prettyPrint . genTopLevelFuncFFI tih) tfns) `connRet2` intercalate "\n\n" (map (intercalateWith connRet prettyPrint) (map genTopLevelFuncDef tfns)) in subst- "module $summarymod (\n\+ "{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}\n\+ \module $summarymod (\n\ \ $exportList\n\ \) where\n\ \\n\
lib/FFICXX/Generate/Type/Class.hs view
@@ -23,9 +23,7 @@ import Data.List import qualified Data.Map as M import Data.Monoid ( (<>) )-import Language.Haskell.Exts.Syntax ( Asst(..), Context- , Splice(..), Type(..), unit_tycon- )+import Language.Haskell.Exts.Syntax ( Asst(..), Context, Splice(..), Type(..) ) import System.FilePath -- import FFICXX.Generate.Util@@ -68,6 +66,9 @@ | TemplateApp { tapp_hstemplate :: TemplateClass , tapp_HaskellTypeForParam :: String , tapp_CppTypeForParam :: String }+ | TemplateAppRef { tappref_hstemplate :: TemplateClass+ , tappref_HaskellTypeForParam :: String+ , tappref_CppTypeForParam :: String } | TemplateType TemplateClass | TemplateParam String deriving Show@@ -375,6 +376,7 @@ NoConst -> cname <> "_p " <> varname where cname = class_name c argToString (TemplateApp _ _ _,varname) = "void* " <> varname+argToString (TemplateAppRef _ _ _,varname) = "void* " <> varname argToString _ = error "undefined argToString" argsToString :: Args -> String@@ -393,7 +395,9 @@ argToCallString (CPT (CPTClassRef c) _,varname) = "to_nonconstref<"<>str<>","<>str<>"_t>(*"<>varname<>")" where str = class_name c argToCallString (TemplateApp _ _ cp,varname) =- "to_nonconst<"<>str<>",void>("<>varname<>")" where str = cp + "to_nonconst<"<>str<>",void>("<>varname<>")" where str = cp+argToCallString (TemplateAppRef _ _ cp,varname) =+ "*( ("<> str <> "*) " <>varname<>")" where str = cp argToCallString (_,varname) = varname argsToCallString :: Args -> String@@ -408,6 +412,7 @@ rettypeToString (CPT (CPTClassRef c) _) = class_name c <> "_p" rettypeToString (CPT (CPTClassCopy c) _) = class_name c <> "_p" rettypeToString (TemplateApp _ _ _) = "void*"+rettypeToString (TemplateAppRef _ _ _) = "void*" rettypeToString (TemplateType _) = "void*" rettypeToString (TemplateParam _) = "Type ## _p" @@ -423,6 +428,7 @@ Const -> "const_" <> class_name c <> "_p " <> varname NoConst -> class_name c <> "_p " <> varname tmplArgToString _ (TemplateApp _ _ _,_v) = error "tmpArgToString: TemplateApp"+tmplArgToString _ (TemplateAppRef _ _ _,_v) = error "tmpArgToString: TemplateAppRef" tmplArgToString _ (TemplateType _,v) = "void* " <> v tmplArgToString _ (TemplateParam _,v) = "Type " <> v tmplArgToString _ _ = error "tmplArgToString: undefined"@@ -462,6 +468,7 @@ tmplRetTypeToString _ (CPT (CPTClassRef c) _) = class_name c <> "_p" tmplRetTypeToString _ (CPT (CPTClassCopy c) _) = class_name c <> "_p" tmplRetTypeToString _ (TemplateApp _ _ _) = "void*"+tmplRetTypeToString _ (TemplateAppRef _ _ _) = "void*" tmplRetTypeToString _ (TemplateType _) = "void*" tmplRetTypeToString b (TemplateParam _) = if b then "Type"@@ -474,9 +481,16 @@ newtype ProtectedMethod = Protected { unProtected :: [String] } deriving (Monoid) +data AddCInc = AddCInc FilePath String++data AddCSrc = AddCSrc FilePath String++ data Cabal = Cabal { cabal_pkgname :: String , cabal_cheaderprefix :: String , cabal_moduleprefix :: String+ , cabal_additional_c_incs :: [AddCInc]+ , cabal_additional_c_srcs :: [AddCSrc] } data CabalAttr = CabalAttr { cabalattr_license :: Maybe String@@ -509,6 +523,16 @@ , class_funcs :: [Function] } +instance Show Class where+ show x = show (class_name x)++instance Eq Class where+ (==) x y = class_name x == class_name y++instance Ord Class where+ compare x y = compare (class_name x) (class_name y)++ data TemplateFunction = TFun { tfun_ret :: Types , tfun_name :: String , tfun_oname :: String@@ -516,6 +540,7 @@ , tfun_alias :: Maybe String } | TFunNew { tfun_new_args :: Args } | TFunDelete+-- deriving (Show,Eq,Ord) data TemplateClass = TmplCls { tclass_cabal :: Cabal , tclass_name :: String@@ -523,12 +548,18 @@ , tclass_param :: String , tclass_funcs :: [TemplateFunction] }+-- deriving (Show,Eq,Ord) instance Show TemplateClass where show x = show (tclass_name x <> " " <> tclass_param x) +instance Eq TemplateClass where+ (==) x y = tclass_name x == tclass_name y +instance Ord TemplateClass where+ compare x y = compare (tclass_name x) (tclass_name y) + data ClassGlobal = ClassGlobal { cgDaughterSelfMap :: DaughterMap , cgDaughterMap :: DaughterMap@@ -544,15 +575,10 @@ isAbstractClass Class{} = False isAbstractClass AbstractClass{} = True -instance Show Class where- show x = show (class_name x) -instance Eq Class where- (==) x y = class_name x == class_name y -instance Ord Class where- compare x y = compare (class_name x) (class_name y) + type DaughterMap = M.Map String [Class] class_allparents :: Class -> [Class]@@ -613,12 +639,13 @@ 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 (TemplateAppRef 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 :: CTypes -> Type () convertC2HS CTString = tycon "CString" convertC2HS CTChar = tycon "CChar" convertC2HS CTInt = tycon "CInt"@@ -626,16 +653,16 @@ convertC2HS CTLong = tycon "CLong" convertC2HS CTULong = tycon "CULong" convertC2HS CTDouble = tycon "CDouble"-convertC2HS CTDoubleStar = TyApp (tycon "Ptr") (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)+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 :: 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 "@@ -643,12 +670,13 @@ 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 (TemplateApp t p _) = tyapp (tycon (tclass_name t)) (tycon p)+convertCpp2HS _c (TemplateAppRef 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 :: 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 "@@ -657,6 +685,7 @@ 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 _ (TemplateAppRef _ _ _ ) = e convertCpp2HS4Tmpl e _c _ (TemplateType _) = e convertCpp2HS4Tmpl _ _c t (TemplateParam _) = t @@ -752,10 +781,10 @@ destructorName = "delete" -classConstraints :: Class -> Context-classConstraints = map ((\n->ClassA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents +classConstraints :: Class -> Context ()+classConstraints = cxTuple . map ((\n->classA (unqual n) [mkTVar "a"]) . typeclassName) . class_parents -extractArgRetTypes :: Maybe Class -> Bool -> (Args,Types) -> ([Type],[Asst]) +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@@ -764,21 +793,21 @@ 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])+ 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]+ 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"]+ ctxt = classA (unqual "Castable") [tvar,tycon "CString"] put (ctxt:ctxts,n+1) return tvar @@ -790,49 +819,51 @@ 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)))+ (TemplateApp t p _) -> return (tyapp (tycon (tclass_name t)) (tycon p))+ (TemplateAppRef 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 :: Class -> Function -> Type () functionSignature c f =- let (typs,ctxts) = extractArgRetTypes (Just c) (isVirtualFunc f) (genericFuncArgs f,genericFuncRet f)+ let (typs,assts) = extractArgRetTypes (Just c) (isVirtualFunc f) (genericFuncArgs f,genericFuncRet f)+ ctxt = cxTuple assts arg0 | isVirtualFunc f = (mkTVar "a" :)- | isNonVirtualFunc f = (mkTVar (class_name c) :)+ | isNonVirtualFunc f = (mkTVar (fst (hsClassName c)) :) | otherwise = id- in TyForall Nothing ctxts (foldr1 TyFun (arg0 typs))+ in TyForall () Nothing (Just ctxt) (foldr1 tyfun (arg0 typs)) -functionSignatureT :: TemplateClass -> TemplateFunction -> Type+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) :)+ arg0 = (tyapp (tycon hname) (mkTVar tp) :) lst = arg0 (map (convertCpp2HS Nothing . fst) tfun_args)- in foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp])+ 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])+ 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)+ in ctyp `tyfun` (tyapp (tycon "IO") unit_tycon) -functionSignatureTT :: TemplateClass -> TemplateFunction -> Type-functionSignatureTT t f = foldr1 TyFun (lst <> [TyApp (tycon "IO") ctyp])+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)))+ 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@@ -842,42 +873,50 @@ -- | this is for FFI type.-hsFFIFuncTyp :: Maybe (Selfness, Class) -> (Args,Types) -> 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+ foldr1 tyfun $ case msc of+ Nothing -> argtyps <> [tyapp (tycon "IO") rettyp]+ Just (Self,_) -> selftyp: argtyps <> [tyapp (tycon "IO") rettyp]+ Just (NoSelf,_) -> argtyps <> [tyapp (tycon "IO") rettyp]+ where argtyps :: [Type ()]+ argtyps = map (hsargtype . fst) args+ rettyp :: Type () rettyp = hsrettype ret selftyp = case msc of- Just (_,c) -> TyApp tyPtr (tycon (snd (hsClassName c)))+ Just (_,c) -> tyapp tyPtr (tycon (snd (hsClassName c))) Nothing -> error "hsFFIFuncTyp: no self for top level function"+ hsargtype :: Types -> Type () hsargtype (CT ctype _) = tycon (hsCTypeName ctype)- hsargtype (CPT (CPTClass d) _) = TyApp tyPtr (tycon rawname)+ hsargtype (CPT (CPTClass d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d)- hsargtype (CPT (CPTClassRef d) _) = TyApp tyPtr (tycon rawname)+ hsargtype (CPT (CPTClassRef d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d)- hsargtype (TemplateApp t p _) = TyApp tyPtr (TyApp (tycon rawname) (tycon p))+ 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)))+ hsargtype (TemplateAppRef t p _) = tyapp tyPtr (tyapp (tycon rawname) (tycon p)) where rawname = snd (hsTemplateClassName t)- hsargtype (TemplateParam p) = mkTVar p- hsargtype SelfType = selftyp+ + 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)+ ---------------------------------------------------------+ 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)+ hsrettype (CPT (CPTClassRef d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d)- hsrettype (CPT (CPTClassCopy d) _) = TyApp tyPtr (tycon rawname)+ hsrettype (CPT (CPTClassCopy d) _) = tyapp tyPtr (tycon rawname) where rawname = snd (hsClassName d)- hsrettype (TemplateApp t p _) = TyApp tyPtr (TyApp (tycon rawname) (tycon p))+ 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)))+ hsrettype (TemplateAppRef 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+ hsrettype (TemplateParam p) = mkTVar p
lib/FFICXX/Generate/Type/Module.hs view
@@ -59,6 +59,8 @@ , pcfg_topLevelImportHeader :: TopLevelImportHeader , pcfg_templateClassModules :: [TemplateClassModule] , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader]+ , pcfg_additional_c_incs :: [AddCInc]+ , pcfg_additional_c_srcs :: [AddCSrc] }
lib/FFICXX/Generate/Util/HaskellSrcExts.hs view
@@ -1,7 +1,8 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : FFICXX.Generate.Util.HaskellSrcExts--- Copyright : (c) 2011-2016 Ian-Woo Kim+-- Copyright : (c) 2011-2017 Ian-Woo Kim -- -- License : BSD3 -- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>@@ -13,95 +14,201 @@ module FFICXX.Generate.Util.HaskellSrcExts where -import Language.Haskell.Exts-import Language.Haskell.Exts.SrcLoc+import Data.List (foldl')+import Data.Maybe+import Language.Haskell.Exts hiding (unit_tycon)+import qualified Language.Haskell.Exts (unit_tycon) -unqual :: String -> QName-unqual = UnQual . Ident -tycon :: String -> Type-tycon = TyCon . unqual+unqual :: String -> QName ()+unqual = UnQual () . Ident () -conDecl :: String -> [Type] -> ConDecl-conDecl n ys = ConDecl (Ident n) ys+tycon :: String -> Type ()+tycon = TyCon () . unqual -recDecl :: String -> [([Name],Type)] -> ConDecl-recDecl n rs = RecDecl (Ident n) rs+tyapp :: Type () -> Type () -> Type ()+tyapp = TyApp () -app :: String -> String -> Exp-app x y = App (mkVar x) (mkVar y)+tyfun :: Type () -> Type () -> Type ()+tyfun = TyFun () -mkVar :: String -> Exp-mkVar = Var . unqual+tylist :: Type () -> Type ()+tylist = TyList () -con :: String -> Exp-con = Con . unqual+unit_tycon :: Type ()+unit_tycon = Language.Haskell.Exts.unit_tycon () -mkTVar :: String -> Type-mkTVar = TyVar . Ident+conDecl :: String -> [Type ()] -> ConDecl ()+conDecl n ys = ConDecl () (Ident () n) ys -mkPVar :: String -> Pat-mkPVar = PVar . Ident+qualConDecl = QualConDecl () -mkPVarSig :: String -> Type -> Pat-mkPVarSig n typ = PatTypeSig noLoc (mkPVar n) typ+recDecl :: String -> [FieldDecl ()] -> ConDecl () -- [([Name ()],Type ())] -> ConDecl ()+recDecl n rs = RecDecl () (Ident () n) rs -pbind :: Pat -> Exp -> Maybe Binds -> Decl-pbind pat e = PatBind noLoc pat (UnGuardedRhs e)+-- app :: Exp () -> Exp () -> Exp ()+-- app = App () -mkTBind :: String -> TyVarBind-mkTBind = UnkindedVar . Ident+app' :: String -> String -> Exp ()+app' x y = App () (mkVar x) (mkVar y) -mkBind1 :: String -> [Pat] -> Exp -> Maybe Binds -> Decl++lit :: Literal () -> Exp ()+lit = Lit ()+++mkVar :: String -> Exp () +mkVar = Var () . unqual++con :: String -> Exp ()+con = Con () . unqual++mkTVar :: String -> Type () +mkTVar = TyVar () . Ident ()++mkPVar :: String -> Pat ()+mkPVar = PVar () . Ident ()++mkIVar :: String -> ImportSpec ()+mkIVar = IVar () . Ident ()++mkPVarSig :: String -> Type () -> Pat ()+mkPVarSig n typ = PatTypeSig () (mkPVar n) typ++pbind :: Pat () -> Exp () -> Maybe (Binds ()) -> Decl ()+pbind pat e = PatBind () pat (UnGuardedRhs () e)++mkTBind :: String -> TyVarBind ()+mkTBind = UnkindedVar () . Ident ()++mkBind1 :: String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl () mkBind1 n pat rhs mbinds =- FunBind [ Match noLoc (Ident n) pat Nothing (UnGuardedRhs rhs) mbinds ]+ FunBind () [ Match () (Ident () n) pat (UnGuardedRhs () rhs) mbinds ] -mkFun :: String -> Type -> [Pat] -> Exp -> Maybe Binds -> [Decl]+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+mkFunSig :: String -> Type () -> Decl ()+mkFunSig fname typ = TypeSig () [Ident () fname] typ -mkClass :: Context -> String -> [TyVarBind] -> [ClassDecl] -> Decl-mkClass ctxt n tbinds cdecls = ClassDecl noLoc ctxt (Ident n) tbinds [] cdecls+mkClass :: Context () -> String -> [TyVarBind ()] -> [ClassDecl ()] -> Decl ()+mkClass ctxt n tbinds cdecls = ClassDecl () (Just ctxt) (mkDeclHead n tbinds) [] (Just 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+dhead :: String -> DeclHead ()+dhead n = DHead () (Ident () n) -mkNewtype :: String -> [TyVarBind] -> [QualConDecl] -> [Deriving] -> Decl-mkNewtype n tbinds qdecls derivs = DataDecl noLoc NewType [] (Ident n) tbinds qdecls derivs+mkDeclHead :: String -> [TyVarBind ()] -> DeclHead ()+mkDeclHead n tbinds = foldl' (DHApp ()) (dhead n) tbinds -mkForImpCcall :: String -> String -> Type -> Decl-mkForImpCcall quote n typ = ForImp noLoc CCall (PlaySafe False) quote (Ident n) typ+mkInstance :: Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()+mkInstance ctxt n typs idecls = InstDecl () Nothing instrule (Just idecls)+ where instrule = IRule () Nothing (Just ctxt) insthead+ insthead = foldl' f (IHCon () (unqual n)) typs+ where f acc x = IHApp () acc (tyParen x) -mkModule :: String -> [ModulePragma] -> [ImportDecl] -> [Decl] -> Module-mkModule n pragmas idecls decls = Module noLoc (ModuleName n) pragmas Nothing Nothing idecls decls+mkData :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()+#if MIN_VERSION_haskell_src_exts(1,20,0)+mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls (maybeToList mderiv)+#else+mkData n tbinds qdecls mderiv = DataDecl () (DataType ()) Nothing declhead qdecls mderiv+#endif+ where declhead = mkDeclHead n tbinds -mkModuleE :: String -> [ModulePragma] -> [ExportSpec] -> [ImportDecl] -> [Decl] -> Module-mkModuleE n pragmas exps idecls decls = Module noLoc (ModuleName n) pragmas Nothing (Just exps) idecls decls+mkNewtype :: String -> [TyVarBind ()] -> [QualConDecl ()] -> Maybe (Deriving ()) -> Decl ()+#if MIN_VERSION_haskell_src_exts(1,20,0)+mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls (maybeToList mderiv)+#else+mkNewtype n tbinds qdecls mderiv = DataDecl () (NewType ()) Nothing declhead qdecls mderiv+#endif+ where declhead = mkDeclHead n tbinds -mkImport :: String -> ImportDecl-mkImport m = ImportDecl noLoc (ModuleName m) False False False Nothing Nothing Nothing+mkForImpCcall :: String -> String -> Type () -> Decl ()+mkForImpCcall quote n typ = ForImp () (CCall ()) (Just (PlaySafe () False)) (Just quote) (Ident () n) typ -mkImportExp :: String -> [String] -> ImportDecl-mkImportExp m lst = ImportDecl noLoc (ModuleName m) False False False Nothing Nothing- (Just (False,map (IVar . Ident) lst))+mkModule :: String -> [ModulePragma ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()+mkModule n pragmas idecls decls = Module () (Just mhead) pragmas idecls decls+ where mhead = ModuleHead () (ModuleName () n) Nothing Nothing -mkImportSrc :: String -> ImportDecl -mkImportSrc m = ImportDecl noLoc (ModuleName m) False True False Nothing Nothing Nothing+mkModuleE :: String -> [ModulePragma ()] -> [ExportSpec ()] -> [ImportDecl ()] -> [Decl ()] -> Module ()+mkModuleE n pragmas exps idecls decls = Module () (Just mhead) pragmas idecls decls+ where mhead = ModuleHead () (ModuleName () n) Nothing (Just eslist)+ eslist = ExportSpecList () exps -lang :: [String] -> ModulePragma-lang ns = LanguagePragma noLoc (map Ident ns)+mkImport :: String -> ImportDecl ()+mkImport m = ImportDecl () (ModuleName () m) False False False Nothing Nothing Nothing -dot :: Exp -> Exp -> Exp-x `dot` y = x `App` mkVar "." `App` y+mkImportExp :: String -> [String] -> ImportDecl ()+mkImportExp m lst =+ ImportDecl () (ModuleName () m) False False False Nothing Nothing (Just islist)+ where islist = ImportSpecList () False (map mkIVar lst) -tyPtr :: Type+ +mkImportSrc :: String -> ImportDecl () +mkImportSrc m = ImportDecl () (ModuleName () m) False True False Nothing Nothing Nothing++lang :: [String] -> ModulePragma ()+lang ns = LanguagePragma () (map (Ident ()) ns)++dot :: Exp () -> Exp () -> Exp ()+x `dot` y = x `app` mkVar "." `app` y++tyForall = TyForall ()++tyParen = TyParen ()++tyPtr :: Type () tyPtr = tycon "Ptr" -tyForeignPtr :: Type+tyForeignPtr :: Type () tyForeignPtr = tycon "ForeignPtr" +classA :: QName () -> [Type ()] -> Asst ()+classA = ClassA ()++cxEmpty :: Context ()+cxEmpty = CxEmpty ()++cxTuple :: [Asst ()] -> Context ()+cxTuple = CxTuple ()++tySplice :: Splice () -> Type ()+tySplice = TySplice ()++parenSplice :: Exp () -> Splice ()+parenSplice = ParenSplice ()++bracketExp = BracketExp ()+typeBracket = TypeBracket ()+++#if MIN_VERSION_haskell_src_exts(1,20,0)+mkDeriving = Deriving () Nothing+#else+mkDeriving = Deriving ()+#endif++irule = IRule ()++ihcon = IHCon ()++evar = EVar ()+eabs = EAbs ()+ethingwith = EThingWith ()++ethingall q = ethingwith (EWildcard () 0) q []++nonamespace = NoNamespace ()++list = List ()+lambda = Lambda ()++insType = InsType ()+insDecl = InsDecl ()++generator = Generator ()++clsDecl = ClsDecl ()+++unkindedVar = UnkindedVar ()
sample/mysample-generator/MySampleGen.hs view
@@ -1,47 +1,44 @@ {-# LANGUAGE ScopedTypeVariables #-} -import Data.Default (def)-import Data.Monoid (mempty)-import System.FilePath ((</>))-import System.Directory (getCurrentDirectory)-import Text.StringTemplate hiding (render)----import FFICXX.Generate.Builder (mkCabalFile)-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.Builder import FFICXX.Generate.Type.Class+import FFICXX.Generate.Type.Module import FFICXX.Generate.Type.PackageInterface----import qualified FFICXX.Paths_fficxx as F -mysampleclasses = [ ]+incs = [ AddCInc "test.h" "//test ok?" ] +srcs = [ AddCSrc "test.cpp" "//test ok??" ]++ mycabal = Cabal { cabal_pkgname = "MySample" , cabal_cheaderprefix = "MySample" , cabal_moduleprefix = "MySample"+ , cabal_additional_c_incs = incs+ , cabal_additional_c_srcs = srcs } +mycabalattr = + CabalAttr + { cabalattr_license = Just "BSD3"+ , cabalattr_licensefile = Just "LICENSE"+ , cabalattr_extraincludedirs = []+ , cabalattr_extralibdirs = []+ , cabalattr_extrafiles = []+ }++ myclass = Class mycabal a :: Class a = myclass "A" [] mempty Nothing [ Constructor [] Nothing- , Virtual void_ "Foo" [ ] Nothing- , Virtual void_ "Foo2" [ long "t" ] Nothing+ , Virtual void_ "method1" [ ] Nothing ] b :: Class b = myclass "B" [a] mempty Nothing [ Constructor [] Nothing- , Virtual void_ "Bar" [] Nothing+ , Virtual (cppclass_ a) "method2" [ cppclass a "x" ] Nothing ] myclasses = [ a, b]@@ -50,71 +47,6 @@ main :: IO ()-main = do- putStrLn "generate mysample"- cwd <- getCurrentDirectory+main = do + simpleBuilder "MySample" [] (mycabal,mycabalattr,myclasses,toplevelfunctions,[]) [ ] [] - let mycabalattr = def- { cabalattr_extralibdirs = [cwd </> ".." </> "cxxlib" </> "lib"]- , cabalattr_extraincludedirs = [cwd </> ".." </> "cxxlib" </> "include"]- }- cfg = FFICXXConfig { fficxxconfig_scriptBaseDir = cwd- , fficxxconfig_workingDir = cwd </> "working"- , fficxxconfig_installBaseDir = cwd </> "MySample"- }- workingDir = fficxxconfig_workingDir cfg- installDir = fficxxconfig_installBaseDir cfg- pkgname = "MySample"- (mods,cihs,tih) = mkAll_ClassModules_CIH_TIH ("MySample", (\c->([],[HdrName $ class_name c ++ ".h"]))) (myclasses,toplevelfunctions)- hsbootlst = mkHSBOOTCandidateList mods- cglobal = mkGlobal myclasses- summarymodule = "MySample"- cabalFileName = "MySample.cabal"- extralibs = ["mysample"]- templateDir <- F.getDataDir >>= return . (</> "template")- (templates :: STGroup String) <- directoryGroup templateDir- --- notExistThenCreate workingDir- notExistThenCreate installDir- notExistThenCreate (installDir </> "src")- notExistThenCreate (installDir </> "csrc")- --- putStrLn "cabal file generation"- mkCabalFile cfg templates (mycabal, mycabalattr) summarymodule (tih, mods) extralibs (workingDir </> cabalFileName)- --- putStrLn "header file generation"- writeTypeDeclHeaders templates workingDir (TypMcro "__MYSAMPLE__") pkgname cihs- mapM_ (writeDeclHeaders templates workingDir (TypMcro "__MYSAMPLE__") pkgname) cihs- --- putStrLn "cpp file generation"- mapM_ (writeCppDef templates workingDir) cihs- --- putStrLn "RawType.hs file generation"- mapM_ (writeRawTypeHs templates workingDir) mods- --- putStrLn "FFI.hsc file generation"- mapM_ (writeFFIHsc templates workingDir) mods- --- putStrLn "Interface.hs file generation"- mapM_ (writeInterfaceHs mempty templates workingDir) mods- --- putStrLn "Cast.hs file generation"- mapM_ (writeCastHs templates workingDir) mods- --- putStrLn "Implementation.hs file generation"- mapM_ (writeImplementationHs mempty templates workingDir) mods- --- putStrLn "hs-boot file generation"- mapM_ (writeInterfaceHSBOOT templates workingDir) hsbootlst- --- putStrLn "module file generation"- mapM_ (writeModuleHs templates workingDir) mods- --- putStrLn "summary module generation generation"- writePkgHs summarymodule templates workingDir mods tih- --- putStrLn "copying"- copyFileWithMD5Check (workingDir </> cabalFileName) (installDir </> cabalFileName)- -- copyPredefined templateDir (srcDir ibase) pkgname- copyCppFiles workingDir (csrcDir installDir) pkgname (tih,cihs)- mapM_ (copyModule workingDir (srcDir installDir) summarymodule) mods
sample/snappy-generator/SnappyGen.hs view
@@ -57,10 +57,10 @@ toplevelfunctions = [ TopLevelFunction ulong_ "Compress" [cppclass source "src", cppclass sink "snk"] Nothing , TopLevelFunction bool_ "GetUncompressedLength" [cppclass source "src", star CTUInt "result"] Nothing - , TopLevelFunction ulong_ "Compress" [cstar CTChar "input", ulong "input_length", cppclass string "output"] (Just "compress_1")- , TopLevelFunction bool_ "Uncompress" [cstar CTChar "compressed", ulong "compressed_length", cppclass string "uncompressed"] Nothing - , TopLevelFunction void_ "RawCompress" [cstar CTChar "input", ulong "input_length", star CTChar "compresseed", star CTULong "compressed_length" ] Nothing- , TopLevelFunction bool_ "RawUncompress" [cstar CTChar "compressed", ulong "compressed_length", star CTChar "uncompressed"] Nothing + , TopLevelFunction ulong_ "Compress" [cstring "input", ulong "input_length", cppclass string "output"] (Just "compress_1")+ , TopLevelFunction bool_ "Uncompress" [cstring "compressed", ulong "compressed_length", cppclass string "uncompressed"] Nothing + , TopLevelFunction void_ "RawCompress" [cstring "input", ulong "input_length", star CTChar "compresseed", star CTULong "compressed_length" ] Nothing+ , TopLevelFunction bool_ "RawUncompress" [cstring "compressed", ulong "compressed_length", star CTChar "uncompressed"] Nothing , TopLevelFunction bool_ "RawUncompress" [cppclass source "src", star CTChar "uncompressed"] (Just "rawUncompress_1") , TopLevelFunction ulong_ "MaxCompressedLength" [ ulong "source_bytes" ] Nothing , TopLevelFunction bool_ "GetUncompressedLength" [ cstar CTChar "compressed", ulong "compressed_length", star CTULong "result" ] (Just "getUncompressedLength_1")
sample/snappy-generator/testSnappy.hs view
@@ -29,14 +29,18 @@ (obstr,len) <- BU.unsafeUseAsCString bstr $ \cstr -> do p_ostr <- mallocArray 1000 p_len <- malloc :: IO (Ptr CULong)+ ----------------------------- rawCompress cstr 1000 p_ostr p_len+ ----------------------------- len <- S.peek p_len putStrLn $ "compressed size = " ++ (show len) (,) <$> BU.unsafePackCString p_ostr <*> pure len rstr <- BU.unsafeUseAsCString obstr $ \cstr -> do p_ostr <- mallocArray 10000- b <- rawUncompress cstr len p_ostr + --------------------+ b <- rawUncompress cstr len p_ostr+ -------------------- putStrLn $ "success? " ++ show b BU.unsafePackCString p_ostr