diff --git a/fficxx.cabal b/fficxx.cabal --- a/fficxx.cabal +++ b/fficxx.cabal @@ -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, diff --git a/lib/FFICXX/Generate/Builder.hs b/lib/FFICXX/Generate/Builder.hs --- a/lib/FFICXX/Generate/Builder.hs +++ b/lib/FFICXX/Generate/Builder.hs @@ -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 () diff --git a/lib/FFICXX/Generate/Code/Cabal.hs b/lib/FFICXX/Generate/Code/Cabal.hs --- a/lib/FFICXX/Generate/Code/Cabal.hs +++ b/lib/FFICXX/Generate/Code/Cabal.hs @@ -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) diff --git a/lib/FFICXX/Generate/Code/Dependency.hs b/lib/FFICXX/Generate/Code/Dependency.hs --- a/lib/FFICXX/Generate/Code/Dependency.hs +++ b/lib/FFICXX/Generate/Code/Dependency.hs @@ -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 @@ -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) diff --git a/lib/FFICXX/Generate/Code/HsFFI.hs b/lib/FFICXX/Generate/Code/HsFFI.hs --- a/lib/FFICXX/Generate/Code/HsFFI.hs +++ b/lib/FFICXX/Generate/Code/HsFFI.hs @@ -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 @@ -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 diff --git a/lib/FFICXX/Generate/Code/HsFrontEnd.hs b/lib/FFICXX/Generate/Code/HsFrontEnd.hs --- a/lib/FFICXX/Generate/Code/HsFrontEnd.hs +++ b/lib/FFICXX/Generate/Code/HsFrontEnd.hs @@ -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 @@ -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") ] diff --git a/lib/FFICXX/Generate/Code/MethodDef.hs b/lib/FFICXX/Generate/Code/MethodDef.hs --- a/lib/FFICXX/Generate/Code/MethodDef.hs +++ b/lib/FFICXX/Generate/Code/MethodDef.hs @@ -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 <> ");" diff --git a/lib/FFICXX/Generate/ContentMaker.hs b/lib/FFICXX/Generate/ContentMaker.hs --- a/lib/FFICXX/Generate/ContentMaker.hs +++ b/lib/FFICXX/Generate/ContentMaker.hs @@ -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\ diff --git a/lib/FFICXX/Generate/Type/Class.hs b/lib/FFICXX/Generate/Type/Class.hs --- a/lib/FFICXX/Generate/Type/Class.hs +++ b/lib/FFICXX/Generate/Type/Class.hs @@ -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 diff --git a/lib/FFICXX/Generate/Type/Module.hs b/lib/FFICXX/Generate/Type/Module.hs --- a/lib/FFICXX/Generate/Type/Module.hs +++ b/lib/FFICXX/Generate/Type/Module.hs @@ -59,6 +59,8 @@ , pcfg_topLevelImportHeader :: TopLevelImportHeader , pcfg_templateClassModules :: [TemplateClassModule] , pcfg_templateClassImportHeaders :: [TemplateClassImportHeader] + , pcfg_additional_c_incs :: [AddCInc] + , pcfg_additional_c_srcs :: [AddCSrc] } diff --git a/lib/FFICXX/Generate/Util/HaskellSrcExts.hs b/lib/FFICXX/Generate/Util/HaskellSrcExts.hs --- a/lib/FFICXX/Generate/Util/HaskellSrcExts.hs +++ b/lib/FFICXX/Generate/Util/HaskellSrcExts.hs @@ -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 @@ -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 () diff --git a/sample/mysample-generator/MySampleGen.hs b/sample/mysample-generator/MySampleGen.hs --- a/sample/mysample-generator/MySampleGen.hs +++ b/sample/mysample-generator/MySampleGen.hs @@ -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 diff --git a/sample/snappy-generator/SnappyGen.hs b/sample/snappy-generator/SnappyGen.hs --- a/sample/snappy-generator/SnappyGen.hs +++ b/sample/snappy-generator/SnappyGen.hs @@ -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") diff --git a/sample/snappy-generator/testSnappy.hs b/sample/snappy-generator/testSnappy.hs --- a/sample/snappy-generator/testSnappy.hs +++ b/sample/snappy-generator/testSnappy.hs @@ -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