fficxx-0.4: lib/FFICXX/Generate/Code/Dependency.hs
{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module : FFICXX.Generate.Code.Dependency
-- Copyright : (c) 2011-2017 Ian-Woo Kim
--
-- License : BSD3
-- Maintainer : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------
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
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
-- utility functions
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
-- | class dependency for a given function
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
-- parents = class_parents c
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])) -- ^ (package name,mkIncludeHeaders)
-> ([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)
-- for toplevel
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])) -- ^ (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)