fficxx-0.3: lib/FFICXX/Generate/Code/Dependency.hs
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : FFICXX.Generate.Code.Dependency
-- Copyright : (c) 2011-2016 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
module FFICXX.Generate.Code.Dependency where
import Data.Function ( on )
import qualified Data.HashMap.Strict as HM
import Data.List
import Data.Maybe
import Data.Monoid ( (<>) )
import System.FilePath
--
import FFICXX.Generate.Type.Class
import FFICXX.Generate.Type.Module
import FFICXX.Generate.Type.PackageInterface
-- |
mkPkgHeaderFileName ::Class -> HeaderName
mkPkgHeaderFileName c =
HdrName ((cabal_cheaderprefix.class_cabal) c <> class_name c <.> "h")
-- |
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
-- |
mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]
mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . mkModuleDepCpp
-- |
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)
-- |
extractClassFromType :: Types -> Maybe Class
extractClassFromType Void = Nothing
extractClassFromType SelfType = Nothing
extractClassFromType (CT _ _) = Nothing
extractClassFromType (CPT (CPTClass c) _) = Just c
extractClassFromType (CPT (CPTClassRef c) _) = Just c
extractClassFromType (CPT (CPTClassCopy c) _) = Just c
extractClassFromType (TemplateApp _ _ _) = Nothing
extractClassFromType (TemplateType _) = Nothing
extractClassFromType (TemplateParam _) = Nothing
-- | class dependency for a given function
data Dep4Func = Dep4Func { returnDependency :: Maybe Class
, argumentDependency :: [Class] }
-- |
extractClassDep :: Function -> Dep4Func
extractClassDep (Constructor args _) = Dep4Func Nothing (catMaybes (map (extractClassFromType.fst) args))
extractClassDep (Virtual ret _ args _) =
Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)
extractClassDep (NonVirtual ret _ args _) =
Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)
extractClassDep (Static ret _ args _) =
Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)
extractClassDep (Destructor _) =
Dep4Func Nothing []
extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func
extractClassDepForTopLevelFunction f =
Dep4Func (extractClassFromType ret) (mapMaybe (extractClassFromType.fst) args)
where ret = case f of
TopLevelFunction {..} -> toplevelfunc_ret
TopLevelVariable {..} -> toplevelvar_ret
args = case f of
TopLevelFunction {..} -> toplevelfunc_args
TopLevelVariable {..} -> []
-- |
mkModuleDepRaw :: Class -> [Class]
mkModuleDepRaw c = (nub . filter (/= c) . mapMaybe (returnDependency.extractClassDep) . class_funcs) c
-- |
mkModuleDepHighNonSource :: Class -> [Class]
mkModuleDepHighNonSource 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
in nub (parents <> extclasses)
-- |
mkModuleDepHighSource :: Class -> [Class]
mkModuleDepHighSource 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
-- |
mkModuleDepCpp :: Class -> [Class]
mkModuleDepCpp c =
let fs = class_funcs c
in nub . filter (/= c) $
mapMaybe (returnDependency.extractClassDep) fs
<> concatMap (argumentDependency.extractClassDep) fs
<> (class_parents c)
-- |
mkModuleDepFFI4One :: Class -> [Class]
mkModuleDepFFI4One c =
let fs = class_funcs c
in (<>) <$> mapMaybe (returnDependency.extractClassDep)
<*> concatMap (argumentDependency.extractClassDep)
$ fs
-- |
mkModuleDepFFI :: Class -> [Class]
mkModuleDepFFI c =
let ps = class_allparents c
alldeps' = (concatMap mkModuleDepFFI4One ps) <> mkModuleDepFFI4One c
in nub (filter (/= c) alldeps')
mkClassModule :: (Class->([Namespace],[HeaderName]))
-> [(String,[String])]
-> Class
-> ClassModule
mkClassModule mkincheaders extra c =
ClassModule (getClassModuleBase c) [c] (map (mkCIH mkincheaders) [c]) highs_nonsource
raws highs_source ffis extraimports
where highs_nonsource = (map getClassModuleBase . mkModuleDepHighNonSource) c
raws = (map getClassModuleBase . mkModuleDepRaw) c
highs_source = (map getClassModuleBase . mkModuleDepHighSource) c
ffis = (map getClassModuleBase . mkModuleDepFFI) c
extraimports = fromMaybe [] (lookup (class_name c) extra)
mkClassNSHeaderFromMap :: HM.HashMap String ([Namespace],[HeaderName]) -> Class -> ([Namespace],[HeaderName])
mkClassNSHeaderFromMap m c = fromMaybe ([],[]) (HM.lookup (class_name c) m)
mkTCM :: (TemplateClass,HeaderName) -> TemplateClassModule
mkTCM (t,hdr) = TCM (getTClassModuleBase t) [t] [TCIH t hdr]
mkPackageConfig
:: (String,Class->([Namespace],[HeaderName])) -- ^ (package name,mkIncludeHeaders)
-> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])])
-> PackageConfig
mkPackageConfig (pkgname,mkNS_IncHdrs) (cs,fs,ts,extra) =
let ms = map (mkClassModule mkNS_IncHdrs extra) cs
cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)
cihs = nubBy cmpfunc (concatMap cmCIH ms)
-- for toplevel
tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs
tl_cs2 = mapMaybe (returnDependency . extractClassDepForTopLevelFunction) fs
tl_cs = nubBy ((==) `on` class_name) (tl_cs1 <> tl_cs2)
tl_cihs = catMaybes $
foldr (\c acc-> (find (\x -> (class_name . cihClass) x == class_name c) cihs):acc) [] tl_cs
--
tih = TopLevelImportHeader (pkgname <> "TopLevel") tl_cihs fs
tcms = map mkTCM ts
tcihs = concatMap tcmTCIH tcms
in PkgConfig ms cihs tih tcms tcihs
mkHSBOOTCandidateList :: [ClassModule] -> [String]
mkHSBOOTCandidateList ms = nub (concatMap cmImportedModulesHighSource ms)