{-# LANGUAGE RecordWildCards #-}
-----------------------------------------------------------------------------
-- |
-- Module      : FFICXX.Generate.Dependency
-- Copyright   : (c) 2011-2018 Ian-Woo Kim
--
-- License     : BSD3
-- Maintainer  : Ian-Woo Kim <ianwookim@gmail.com>
-- Stability   : experimental
-- Portability : GHC
--
-----------------------------------------------------------------------------

module FFICXX.Generate.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 qualified Data.Map            as M
import           Data.Maybe
import           Data.Monoid                ((<>))
import           System.FilePath
--
import           FFICXX.Generate.Name       (ffiClassName,hsClassName,hsTemplateClassName)
import           FFICXX.Generate.Type.Cabal (AddCInc,AddCSrc,CabalName(..)
                                            ,cabal_moduleprefix,cabal_pkgname
                                            ,cabal_cheaderprefix,unCabalName)
import           FFICXX.Generate.Type.Class
import           FFICXX.Generate.Type.Config (ModuleUnit(..)
                                             ,ModuleUnitImports(..),emptyModuleUnitImports
                                             ,ModuleUnitMap(..))
import           FFICXX.Generate.Type.Module
import           FFICXX.Generate.Type.PackageInterface


-- utility functions

getcabal = either tclass_cabal class_cabal

getparents = either (const []) (map Right . class_parents)

-- TODO: replace tclass_name with appropriate FFI name when supported.
getFFIName = either tclass_name ffiClassName


getPkgName :: Either TemplateClass Class -> CabalName
getPkgName = cabal_pkgname . getcabal


-- |
extractClassFromType :: Types -> [Either TemplateClass Class]
extractClassFromType Void                     = []
extractClassFromType SelfType                 = []
extractClassFromType (CT _ _)                 = []
extractClassFromType (CPT (CPTClass c) _)     = [Right c]
extractClassFromType (CPT (CPTClassRef c) _)  = [Right c]
extractClassFromType (CPT (CPTClassCopy c) _) = [Right c]
extractClassFromType (CPT (CPTClassMove c) _) = [Right c]
extractClassFromType (TemplateApp (TemplateAppInfo t p _)) =
  (Left t): case p of
              TArg_Class c -> [Right c]
              _            -> []
extractClassFromType (TemplateAppRef (TemplateAppInfo t p _))   =
  (Left t): case p of
              TArg_Class c -> [Right c]
              _            -> []
extractClassFromType (TemplateAppMove (TemplateAppInfo t p _))   =
  (Left t): case p of
              TArg_Class c -> [Right c]
              _            -> []
extractClassFromType (TemplateType t)         = [Left t]
extractClassFromType (TemplateParam _)        = []
extractClassFromType (TemplateParamPointer _) = []


class_allparents :: Class -> [Class]
class_allparents c = let ps = class_parents c
                     in  if null ps
                           then []
                           else nub (ps <> (concatMap class_allparents ps))


getClassModuleBase :: Class -> String
getClassModuleBase = (<.>) <$> (cabal_moduleprefix.class_cabal) <*> (fst.hsClassName)

getTClassModuleBase :: TemplateClass -> String
getTClassModuleBase = (<.>) <$> (cabal_moduleprefix.tclass_cabal) <*> (fst.hsTemplateClassName)


-- | Daughter map not including itself
mkDaughterMap :: [Class] -> DaughterMap
mkDaughterMap = foldl mkDaughterMapWorker M.empty
  where mkDaughterMapWorker m c = let ps = map getClassModuleBase (class_allparents c)
                                  in  foldl (addmeToYourDaughterList c) m ps
        addmeToYourDaughterList c m p = let f Nothing = Just [c]
                                            f (Just cs)  = Just (c:cs)
                                        in  M.alter f p m



-- | Daughter Map including itself as a daughter
mkDaughterSelfMap :: [Class] -> DaughterMap
mkDaughterSelfMap = foldl' worker M.empty
  where worker m c = let ps = map getClassModuleBase (c:class_allparents c)
                     in  foldl (addToList c) m ps
        addToList c m p = let f Nothing = Just [c]
                              f (Just cs)  = Just (c:cs)
                          in  M.alter f p m



-- | class dependency for a given function
data Dep4Func = Dep4Func { returnDependency :: [Either TemplateClass Class]
                         , argumentDependency :: [Either TemplateClass Class] }


-- |
extractClassDep :: Function -> Dep4Func
extractClassDep (Constructor args _)  =
    Dep4Func [] (concatMap (extractClassFromType.fst) args)
extractClassDep (Virtual ret _ args _) =
    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)
extractClassDep (NonVirtual ret _ args _) =
    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)
extractClassDep (Static ret _ args _) =
    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)
extractClassDep (Destructor _) =
    Dep4Func [] []


extractClassDepForTmplFun :: TemplateFunction -> Dep4Func
extractClassDepForTmplFun (TFun ret  _ _ args _) =
    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)
extractClassDepForTmplFun (TFunNew args _) =
    Dep4Func [] (concatMap (extractClassFromType.fst) args)
extractClassDepForTmplFun TFunDelete =
    Dep4Func [] []


extractClassDep4TmplMemberFun :: TemplateMemberFunction -> Dep4Func
extractClassDep4TmplMemberFun (TemplateMemberFunction {..}) =
  Dep4Func (extractClassFromType tmf_ret) (concatMap (extractClassFromType.fst) tmf_args)



extractClassDepForTopLevelFunction :: TopLevelFunction -> Dep4Func
extractClassDepForTopLevelFunction f =
    Dep4Func (extractClassFromType ret) (concatMap (extractClassFromType.fst) args)
  where ret = case f of
                TopLevelFunction {..} -> toplevelfunc_ret
                TopLevelVariable {..} -> toplevelvar_ret
        args = case f of
                 TopLevelFunction {..} -> toplevelfunc_args
                 TopLevelVariable {..} -> []


-- TODO: Confirm the answer below is correct.
-- NOTE: Q: Why returnDependency only?
--       A: Difference between argument and return:
--          for a member function f,
--          we have (f :: (IA a, IB b) => a -> b -> IO C
--          return class is concrete and argument class is constraint.
mkModuleDepRaw :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepRaw x@(Right c) =
  nub $
    filter (/= x) $
         concatMap (returnDependency . extractClassDep) (class_funcs c)
      ++ concatMap (returnDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)
mkModuleDepRaw x@(Left t) =
  (nub . filter (/= x) . concatMap (returnDependency.extractClassDepForTmplFun) . tclass_funcs) t



isNotInSamePackageWith
  :: Either TemplateClass Class
  -> Either TemplateClass Class
  -> Bool
isNotInSamePackageWith x y = (x /= y) && (getPkgName x /= getPkgName y)

-- x is in the sam
isInSamePackageButNotInheritedBy
  :: Either TemplateClass Class -- ^ y
  -> Either TemplateClass Class -- ^ x
  -> Bool
isInSamePackageButNotInheritedBy x y =
  x /= y && not (x `elem` getparents y) && (getPkgName x == getPkgName y)


-- TODO: Confirm the following answer
-- NOTE: Q: why returnDependency is not considered?
--       A: See explanation in mkModuleDepRaw
mkModuleDepHighNonSource :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepHighNonSource y@(Right c) =
  let extclasses = filter (`isNotInSamePackageWith` y) $
                        concatMap (argumentDependency.extractClassDep) (class_funcs c)
                     ++ concatMap (argumentDependency.extractClassDep4TmplMemberFun) (class_tmpl_funcs c)
      parents = map Right (class_parents c)
  in  nub (parents <> extclasses)
mkModuleDepHighNonSource y@(Left t) =
  let fs = tclass_funcs t
      extclasses = filter (`isNotInSamePackageWith` y) $
                     concatMap (argumentDependency.extractClassDepForTmplFun) fs
  in  nub extclasses


-- TODO: Confirm the following answer
-- NOTE: Q: why returnDependency is not considered?
--       A: See explanation in mkModuleDepRaw
mkModuleDepHighSource :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepHighSource y@(Right c) =
  nub $
    filter (`isInSamePackageButNotInheritedBy` y) $
         concatMap (argumentDependency . extractClassDep) (class_funcs c)
      ++ concatMap (argumentDependency . extractClassDep4TmplMemberFun) (class_tmpl_funcs c)
mkModuleDepHighSource y@(Left t) =
  let fs = tclass_funcs t
  in nub $
       filter (`isInSamePackageButNotInheritedBy` y) $
         concatMap (argumentDependency . extractClassDepForTmplFun) fs

-- |
mkModuleDepCpp :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepCpp y@(Right c) =
  let fs = class_funcs c
      vs = class_vars c
      tmfs = class_tmpl_funcs c
  in  nub . filter (/= y)  $
           concatMap (returnDependency.extractClassDep) fs
        <> concatMap (argumentDependency.extractClassDep) fs
        <> concatMap (extractClassFromType . var_type) vs
        <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs
        <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs
        <> getparents y
mkModuleDepCpp y@(Left t) =
  let fs = tclass_funcs t
  in  nub . filter (/= y)  $
           concatMap (returnDependency.extractClassDepForTmplFun) fs
        <> concatMap (argumentDependency.extractClassDepForTmplFun) fs
        <> getparents y

-- |
mkModuleDepFFI1 :: Either TemplateClass Class -> [Either TemplateClass Class]
mkModuleDepFFI1 (Right c) = let fs = class_funcs c
                                vs = class_vars c
                                tmfs = class_tmpl_funcs c
                            in    concatMap (returnDependency.extractClassDep) fs
                               <> concatMap (argumentDependency.extractClassDep) fs
                               <> concatMap (extractClassFromType . var_type) vs
                               <> concatMap (returnDependency.extractClassDep4TmplMemberFun) tmfs
                               <> concatMap (argumentDependency.extractClassDep4TmplMemberFun) tmfs
mkModuleDepFFI1 (Left t)  = let fs = tclass_funcs t
                            in    concatMap (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 mkModuleDepFFI1 ps) <> mkModuleDepFFI1 y
  in nub (filter (/= y) alldeps')
mkModuleDepFFI (Left _) = []


mkClassModule :: (ModuleUnit -> ModuleUnitImports)
              -> [(String,[String])]
              -> Class
              -> ClassModule
mkClassModule getImports extra c =
    ClassModule {
      cmModule = getClassModuleBase c
    , cmClass = [c]
    , cmCIH = map (mkCIH getImports) [c]
    , cmImportedModulesHighNonSource = highs_nonsource
    , cmImportedModulesRaw =raws
    , cmImportedModulesHighSource = highs_source
    , cmImportedModulesForFFI = ffis
    , cmExtraImport = extraimports
    }
  where highs_nonsource = mkModuleDepHighNonSource (Right c)
        raws            = mkModuleDepRaw (Right c)
        highs_source    = mkModuleDepHighSource (Right c)
        ffis            = mkModuleDepFFI (Right c)
        extraimports = fromMaybe [] (lookup (class_name c) extra)


findModuleUnitImports :: ModuleUnitMap -> ModuleUnit -> ModuleUnitImports
findModuleUnitImports m u =
  fromMaybe emptyModuleUnitImports (HM.lookup u (unModuleUnitMap m))


mkTCM :: (TemplateClass,HeaderName) -> TemplateClassModule
mkTCM (t,hdr) = TCM  (getTClassModuleBase t) [t] [TCIH t hdr]


mkPackageConfig
  :: (CabalName, ModuleUnit -> ModuleUnitImports) -- ^ (package name,getImports)
  -> ([Class],[TopLevelFunction],[(TemplateClass,HeaderName)],[(String,[String])])
  -> [AddCInc]
  -> [AddCSrc]
  -> PackageConfig
mkPackageConfig (pkgname,getImports) (cs,fs,ts,extra) acincs acsrcs =
  let ms = map (mkClassModule getImports extra) cs
      cmpfunc x y = class_name (cihClass x) == class_name (cihClass y)
      cihs = nubBy cmpfunc (concatMap cmCIH ms)
      --
      tih = mkTIH pkgname getImports cihs fs
      tcms = map mkTCM ts
      tcihs = concatMap tcmTCIH tcms
  in PkgConfig {
       pcfg_classModules = ms
     , pcfg_classImportHeaders = cihs
     , pcfg_topLevelImportHeader = tih
     , pcfg_templateClassModules = tcms
     , pcfg_templateClassImportHeaders = tcihs
     , pcfg_additional_c_incs = acincs
     , pcfg_additional_c_srcs = acsrcs
     }


-- TODO: change [String] to Set String
mkHSBOOTCandidateList :: [ClassModule] -> [String]
mkHSBOOTCandidateList ms =
  let
    -- get only class dependencies, not template classes.
    cs = rights (concatMap cmImportedModulesHighSource ms)
  in
    nub (map getClassModuleBase cs)



-- |
mkPkgHeaderFileName ::Class -> HeaderName
mkPkgHeaderFileName c =
    HdrName (   (cabal_cheaderprefix.class_cabal) c
            <>  fst (hsClassName c)
            <.> "h"
            )

-- |
mkPkgCppFileName ::Class -> String
mkPkgCppFileName c =
        (cabal_cheaderprefix.class_cabal) c
    <>  fst (hsClassName c)
    <.> "cpp"

-- |
mkPkgIncludeHeadersInH :: Class -> [HeaderName]
mkPkgIncludeHeadersInH c =
    let pkgname = (cabal_pkgname . class_cabal) c
        extclasses = filter ((/= pkgname) . getPkgName) . mkModuleDepCpp $ Right c
        extheaders = nub . map ((<>"Type.h") . unCabalName . getPkgName) $ extclasses
    in map mkPkgHeaderFileName (class_allparents c) <> map HdrName extheaders



-- |
mkPkgIncludeHeadersInCPP :: Class -> [HeaderName]
mkPkgIncludeHeadersInCPP = map mkPkgHeaderFileName . rights . mkModuleDepCpp . Right


-- |
mkCIH :: (ModuleUnit -> ModuleUnitImports)  -- ^ (mk namespace and include headers)
      -> Class
      -> ClassImportHeader
mkCIH getImports c =
  ClassImportHeader {
    cihClass                    = c
  , cihSelfHeader               = mkPkgHeaderFileName c
  , cihNamespace                = (muimports_namespaces . getImports . MU_Class . class_name) c
  , cihSelfCpp                  = mkPkgCppFileName c
  , cihImportedClasses          = mkModuleDepCpp (Right c)
  , cihIncludedHPkgHeadersInH   = mkPkgIncludeHeadersInH c
  , cihIncludedHPkgHeadersInCPP = mkPkgIncludeHeadersInCPP c
  , cihIncludedCPkgHeaders      = (muimports_headers . getImports . MU_Class . class_name) c
  }

-- | for top-level
mkTIH
  :: CabalName
  -> (ModuleUnit -> ModuleUnitImports)
  -> [ClassImportHeader]
  -> [TopLevelFunction]
  -> TopLevelImportHeader
mkTIH pkgname getImports cihs fs =
  let tl_cs1 = concatMap (argumentDependency . extractClassDepForTopLevelFunction) fs
      tl_cs2 = concatMap (returnDependency . extractClassDepForTopLevelFunction) fs
      tl_cs = nubBy ((==) `on` either tclass_name ffiClassName) (tl_cs1 <> tl_cs2)
      -- NOTE: Select only class dependencies in the current package.
      -- TODO: This is clearly not a good impl. we need to look into this again
      --       after reconsidering multi-package generation.
      tl_cihs = catMaybes (foldr fn [] tl_cs)
         where
           fn c ys =
             let y = find (\x -> (ffiClassName . cihClass) x == getFFIName c) cihs
             in y:ys
      -- NOTE: The remaining class dependencies outside the current package
      extclasses = filter ((/= pkgname) . getPkgName) tl_cs
      extheaders = map HdrName $
                     nub $
                       map ((<>"Type.h") . unCabalName . getPkgName)  extclasses

  in
     TopLevelImportHeader {
       tihHeaderFileName = unCabalName pkgname <> "TopLevel"
     , tihClassDep = tl_cihs
     , tihExtraClassDep = extclasses
     , tihFuncs = fs
     , tihNamespaces        = muimports_namespaces (getImports MU_TopLevel)
     , tihExtraHeadersInH   = extheaders
     , tihExtraHeadersInCPP = muimports_headers (getImports MU_TopLevel)
     }