{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TupleSections #-}

module FFICXX.Generate.Dependency.Graph where

import Data.Array (listArray)
import qualified Data.Graph as G
import qualified Data.HashMap.Strict as HM
import qualified Data.List as L
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Tree (flatten)
import Data.Tuple (swap)
import FFICXX.Generate.Dependency
  ( calculateDependency,
    mkTopLevelDep,
  )
import FFICXX.Generate.Name (subModuleName)
import FFICXX.Generate.Type.Class (TopLevel (..))
import FFICXX.Generate.Type.Module
  ( ClassSubmoduleType (..),
    DepCycles,
    TemplateClassSubmoduleType (..),
    UClass,
    UClassSubmodule,
  )

-- TODO: Introduce unique id per submodule.

-- | construct dependency graph
constructDepGraph ::
  -- | list of all classes, either template class or ordinary class.
  [UClass] ->
  -- | list of all top-level functions.
  [TopLevel] ->
  -- | (all submodules, [(submodule, submodule dependencies)])
  ([String], [(Int, [Int])])
constructDepGraph :: [UClass] -> [TopLevel] -> ([String], [(Int, [Int])])
constructDepGraph [UClass]
allClasses [TopLevel]
allTopLevels = ([String]
allSyms, [(Int, [Int])]
depmap')
  where
    -- for classes/template classes
    mkDep :: UClass -> [(UClassSubmodule, [UClassSubmodule])]
    mkDep :: UClass -> [(UClassSubmodule, [UClassSubmodule])]
mkDep UClass
c =
      case UClass
c of
        Left TemplateClass
tcl ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (UClassSubmodule -> (UClassSubmodule, [UClassSubmodule])
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,TemplateClass
tcl))
            [TemplateClassSubmoduleType
TCSTTemplate, TemplateClassSubmoduleType
TCSTTH]
        Right Class
cls ->
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (UClassSubmodule -> (UClassSubmodule, [UClassSubmodule])
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,Class
cls))
            [ClassSubmoduleType
CSTRawType, ClassSubmoduleType
CSTFFI, ClassSubmoduleType
CSTInterface, ClassSubmoduleType
CSTCast, ClassSubmoduleType
CSTImplementation]
      where
        build :: UClassSubmodule -> (UClassSubmodule, [UClassSubmodule])
build UClassSubmodule
x = (UClassSubmodule
x, UClassSubmodule -> [UClassSubmodule]
calculateDependency UClassSubmodule
x)

    dep2Name :: [(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])]
    dep2Name :: [(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])]
dep2Name = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(UClassSubmodule
x, [UClassSubmodule]
ys) -> (UClassSubmodule -> String
subModuleName UClassSubmodule
x, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UClassSubmodule -> String
subModuleName [UClassSubmodule]
ys))
    -- TopLevel
    topLevelDeps :: (String, [String])
    topLevelDeps :: (String, [String])
topLevelDeps =
      let deps :: [String]
deps =
            forall a. Eq a => [a] -> [a]
L.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UClassSubmodule -> String
subModuleName forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> [UClassSubmodule]
mkTopLevelDep) [TopLevel]
allTopLevels
       in (String
"[TopLevel]", [String]
deps)

    depmapAllClasses :: [(String, [String])]
depmapAllClasses = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])]
dep2Name forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClass -> [(UClassSubmodule, [UClassSubmodule])]
mkDep) [UClass]
allClasses
    depmap :: [(String, [String])]
depmap = (String, [String])
topLevelDeps forall a. a -> [a] -> [a]
: [(String, [String])]
depmapAllClasses
    allSyms :: [String]
allSyms =
      forall a. Eq a => [a] -> [a]
L.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
L.sort forall a b. (a -> b) -> a -> b
$
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(String, [String])]
depmap forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a b. (a, b) -> b
snd [(String, [String])]
depmap
    allISyms :: [(Int, String)]
    allISyms :: [(Int, String)]
allISyms = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [String]
allSyms
    symRevMap :: HashMap String Int
symRevMap = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> (b, a)
swap [(Int, String)]
allISyms
    replace :: (String, t String) -> Maybe (Int, t Int)
replace (String
c, t String
ds) = do
      Int
i <- forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
c HashMap String Int
symRevMap
      t Int
js <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (\String
d -> forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
d HashMap String Int
symRevMap) t String
ds
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, t Int
js)
    depmap' :: [(Int, [Int])]
depmap' = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {t :: * -> *}.
Traversable t =>
(String, t String) -> Maybe (Int, t Int)
replace [(String, [String])]
depmap

-- | find grouped dependency cycles
findDepCycles :: ([String], [(Int, [Int])]) -> DepCycles
findDepCycles :: ([String], [(Int, [Int])]) -> DepCycles
findDepCycles ([String]
syms, [(Int, [Int])]
deps) =
  let symMap :: [(Int, String)]
symMap = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [String]
syms
      lookupSym :: Int -> String
lookupSym Int
i = forall a. a -> Maybe a -> a
fromMaybe String
"<NOTFOUND>" (forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Int
i [(Int, String)]
symMap)
      n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
syms
      bounds :: (Int, Int)
bounds = (Int
0, Int
n forall a. Num a => a -> a -> a
- Int
1)
      gr :: Array Int [Int]
gr = forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int, Int)
bounds forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> forall a. a -> Maybe a -> a
fromMaybe [] (forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Int
i [(Int, [Int])]
deps)) [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1]
      lookupSymAndRestrictDeps :: [Int] -> [(String, ([String], [String]))]
      lookupSymAndRestrictDeps :: [Int] -> [(String, ([String], [String]))]
lookupSymAndRestrictDeps [Int]
cycl = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> (String, ([String], [String]))
go [Int]
cycl
        where
          go :: Int -> (String, ([String], [String]))
go Int
i =
            let sym :: String
sym = Int -> String
lookupSym Int
i
                ([Int]
rdepsU, [Int]
rdepsL) =
                  forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (forall a. Ord a => a -> a -> Bool
< Int
i) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
cycl) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] (forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Int
i [(Int, [Int])]
deps)
                ([String]
rdepsU', [String]
rdepsL') = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> String
lookupSym [Int]
rdepsU, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> String
lookupSym [Int]
rdepsL)
             in (String
sym, ([String]
rdepsU', [String]
rdepsL'))
      cycleGroups :: DepCycles
cycleGroups =
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> [(String, ([String], [String]))]
lookupSymAndRestrictDeps forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (\[Int]
xs -> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs forall a. Ord a => a -> a -> Bool
> Int
1) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. Tree a -> [a]
flatten (Array Int [Int] -> Forest Int
G.scc Array Int [Int]
gr)
   in DepCycles
cycleGroups

getCyclicDepSubmodules :: String -> DepCycles -> ([String], [String])
getCyclicDepSubmodules :: String -> DepCycles -> ([String], [String])
getCyclicDepSubmodules String
self DepCycles
depCycles = forall a. a -> Maybe a -> a
fromMaybe ([], []) forall a b. (a -> b) -> a -> b
$ do
  [(String, ([String], [String]))]
cycl <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\[(String, ([String], [String]))]
xs -> String
self forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(String, ([String], [String]))]
xs) DepCycles
depCycles
  forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup String
self [(String, ([String], [String]))]
cycl

-- | locate importing module and imported module in dependency cycles
locateInDepCycles :: (String, String) -> DepCycles -> Maybe (Int, Int)
locateInDepCycles :: (String, String) -> DepCycles -> Maybe (Int, Int)
locateInDepCycles (String
self, String
imported) DepCycles
depCycles = do
  [(String, ([String], [String]))]
cycl <- forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\[(String, ([String], [String]))]
xs -> String
self forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(String, ([String], [String]))]
xs) DepCycles
depCycles
  let cyclNoDeps :: [String]
cyclNoDeps = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(String, ([String], [String]))]
cycl
  Int
idxSelf <- String
self forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` [String]
cyclNoDeps
  Int
idxImported <- String
imported forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` [String]
cyclNoDeps
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
idxSelf, Int
idxImported)

gatherHsBootSubmodules :: DepCycles -> [String]
gatherHsBootSubmodules :: DepCycles -> [String]
gatherHsBootSubmodules DepCycles
depCycles = do
  [(String, ([String], [String]))]
cycl <- DepCycles
depCycles
  (String
_, ([String]
_us, [String]
ds)) <- [(String, ([String], [String]))]
cycl
  String
d <- [String]
ds
  forall (f :: * -> *) a. Applicative f => a -> f a
pure String
d