{-# LANGUAGE RecordWildCards #-}
module FFICXX.Generate.Code.Dependency where
import Data.Either ( rights )
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
import Debug.Trace
getclassname = either tclass_name class_name
getcabal = either tclass_cabal class_cabal
getparents = either (const []) (map Right . class_parents)
getmodulebase = either getTClassModuleBase getClassModuleBase
extractClassFromType :: Types -> Maybe (Either TemplateClass Class)
extractClassFromType Void = Nothing
extractClassFromType SelfType = Nothing
extractClassFromType (CT _ _) = 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
data Dep4Func = Dep4Func { returnDependency :: Maybe (Either TemplateClass Class)
, argumentDependency :: [(Either TemplateClass 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 []
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)
where ret = case f of
TopLevelFunction {..} -> toplevelfunc_ret
TopLevelVariable {..} -> toplevelvar_ret
args = case f of
TopLevelFunction {..} -> toplevelfunc_args
TopLevelVariable {..} -> []
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 :: 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 /= 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
in nub extclasses
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 /= 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 :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepCpp y@(Right c) =
let fs = class_funcs c
in nub . filter (/= y) $
mapMaybe (returnDependency.extractClassDep) fs
<> concatMap (argumentDependency.extractClassDep) fs
<> 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 :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepFFI4One (Right c) =
let fs = class_funcs c
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 :: 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
-> ClassModule
mkClassModule mkincheaders extra c =
ClassModule (getClassModuleBase c) [c] (map (mkCIH mkincheaders) [c]) highs_nonsource
raws highs_source ffis extraimports
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)
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]))
-> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])])
-> [AddCInc]
-> [AddCSrc]
-> PackageConfig
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)
tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs
tl_cs2 = mapMaybe (returnDependency . extractClassDepForTopLevelFunction) fs
tl_cs = nubBy ((==) `on` getclassname) (tl_cs1 <> tl_cs2)
tl_cihs = catMaybes $
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 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]))
-> Class
-> ClassImportHeader
mkCIH mkNSandIncHdrs c = ClassImportHeader c
(mkPkgHeaderFileName c)
((fst . mkNSandIncHdrs) c)
(mkPkgCppFileName c)
(mkPkgIncludeHeadersInH c)
(mkPkgIncludeHeadersInCPP c)
((snd . mkNSandIncHdrs) c)