{-# 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 ->
          (TemplateClassSubmoduleType
 -> (UClassSubmodule, [UClassSubmodule]))
-> [TemplateClassSubmoduleType]
-> [(UClassSubmodule, [UClassSubmodule])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (UClassSubmodule -> (UClassSubmodule, [UClassSubmodule])
build (UClassSubmodule -> (UClassSubmodule, [UClassSubmodule]))
-> (TemplateClassSubmoduleType -> UClassSubmodule)
-> TemplateClassSubmoduleType
-> (UClassSubmodule, [UClassSubmodule])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TemplateClassSubmoduleType, TemplateClass) -> UClassSubmodule
forall a b. a -> Either a b
Left ((TemplateClassSubmoduleType, TemplateClass) -> UClassSubmodule)
-> (TemplateClassSubmoduleType
    -> (TemplateClassSubmoduleType, TemplateClass))
-> TemplateClassSubmoduleType
-> UClassSubmodule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,TemplateClass
tcl))
            [TemplateClassSubmoduleType
TCSTTemplate, TemplateClassSubmoduleType
TCSTTH]
        Right Class
cls ->
          (ClassSubmoduleType -> (UClassSubmodule, [UClassSubmodule]))
-> [ClassSubmoduleType] -> [(UClassSubmodule, [UClassSubmodule])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (UClassSubmodule -> (UClassSubmodule, [UClassSubmodule])
build (UClassSubmodule -> (UClassSubmodule, [UClassSubmodule]))
-> (ClassSubmoduleType -> UClassSubmodule)
-> ClassSubmoduleType
-> (UClassSubmodule, [UClassSubmodule])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClassSubmoduleType, Class) -> UClassSubmodule
forall a b. b -> Either a b
Right ((ClassSubmoduleType, Class) -> UClassSubmodule)
-> (ClassSubmoduleType -> (ClassSubmoduleType, Class))
-> ClassSubmoduleType
-> UClassSubmodule
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 = ((UClassSubmodule, [UClassSubmodule]) -> (String, [String]))
-> [(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(UClassSubmodule
x, [UClassSubmodule]
ys) -> (UClassSubmodule -> String
subModuleName UClassSubmodule
x, (UClassSubmodule -> String) -> [UClassSubmodule] -> [String]
forall a b. (a -> b) -> [a] -> [b]
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 =
            [String] -> [String]
forall a. Eq a => [a] -> [a]
L.nub ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (TopLevel -> [String]) -> [TopLevel] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((UClassSubmodule -> String) -> [UClassSubmodule] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap UClassSubmodule -> String
subModuleName ([UClassSubmodule] -> [String])
-> (TopLevel -> [UClassSubmodule]) -> TopLevel -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TopLevel -> [UClassSubmodule]
mkTopLevelDep) [TopLevel]
allTopLevels
       in (String
"[TopLevel]", [String]
deps)

    depmapAllClasses :: [(String, [String])]
depmapAllClasses = (UClass -> [(String, [String])])
-> [UClass] -> [(String, [String])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])]
dep2Name ([(UClassSubmodule, [UClassSubmodule])] -> [(String, [String])])
-> (UClass -> [(UClassSubmodule, [UClassSubmodule])])
-> UClass
-> [(String, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UClass -> [(UClassSubmodule, [UClassSubmodule])]
mkDep) [UClass]
allClasses
    depmap :: [(String, [String])]
depmap = (String, [String])
topLevelDeps (String, [String]) -> [(String, [String])] -> [(String, [String])]
forall a. a -> [a] -> [a]
: [(String, [String])]
depmapAllClasses
    allSyms :: [String]
allSyms =
      [String] -> [String]
forall a. Eq a => [a] -> [a]
L.nub ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
L.sort ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
        ((String, [String]) -> String) -> [(String, [String])] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, [String]) -> String
forall a b. (a, b) -> a
fst [(String, [String])]
depmap [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, [String]) -> [String])
-> [(String, [String])] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (String, [String]) -> [String]
forall a b. (a, b) -> b
snd [(String, [String])]
depmap
    allISyms :: [(Int, String)]
    allISyms :: [(Int, String)]
allISyms = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [String]
allSyms
    symRevMap :: HashMap String Int
symRevMap = [(String, Int)] -> HashMap String Int
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(String, Int)] -> HashMap String Int)
-> [(String, Int)] -> HashMap String Int
forall a b. (a -> b) -> a -> b
$ ((Int, String) -> (String, Int))
-> [(Int, String)] -> [(String, Int)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, String) -> (String, Int)
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 <- String -> HashMap String Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
c HashMap String Int
symRevMap
      t Int
js <- (String -> Maybe Int) -> t String -> Maybe (t Int)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> t a -> f (t b)
traverse (\String
d -> String -> HashMap String Int -> Maybe Int
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup String
d HashMap String Int
symRevMap) t String
ds
      (Int, t Int) -> Maybe (Int, t Int)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
i, t Int
js)
    depmap' :: [(Int, [Int])]
depmap' = ((String, [String]) -> Maybe (Int, [Int]))
-> [(String, [String])] -> [(Int, [Int])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String, [String]) -> Maybe (Int, [Int])
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 = [Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [String]
syms
      lookupSym :: Int -> String
lookupSym Int
i = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"<NOTFOUND>" (Int -> [(Int, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Int
i [(Int, String)]
symMap)
      n :: Int
n = [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
syms
      bounds :: (Int, Int)
bounds = (Int
0, Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      gr :: Array Int [Int]
gr = (Int, Int) -> [[Int]] -> Array Int [Int]
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Int, Int)
bounds ([[Int]] -> Array Int [Int]) -> [[Int]] -> Array Int [Int]
forall a b. (a -> b) -> a -> b
$ (Int -> [Int]) -> [Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Int
i -> [Int] -> Maybe [Int] -> [Int]
forall a. a -> Maybe a -> a
fromMaybe [] (Int -> [(Int, [Int])] -> Maybe [Int]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Int
i [(Int, [Int])]
deps)) [Int
0 .. Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
      lookupSymAndRestrictDeps :: [Int] -> [(String, ([String], [String]))]
      lookupSymAndRestrictDeps :: [Int] -> [(String, ([String], [String]))]
lookupSymAndRestrictDeps [Int]
cycl = (Int -> (String, ([String], [String])))
-> [Int] -> [(String, ([String], [String]))]
forall a b. (a -> b) -> [a] -> [b]
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) =
                  (Int -> Bool) -> [Int] -> ([Int], [Int])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
i) ([Int] -> ([Int], [Int])) -> [Int] -> ([Int], [Int])
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> [Int] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
cycl) ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> Maybe [Int] -> [Int]
forall a. a -> Maybe a -> a
fromMaybe [] (Int -> [(Int, [Int])] -> Maybe [Int]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
L.lookup Int
i [(Int, [Int])]
deps)
                ([String]
rdepsU', [String]
rdepsL') = ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> String
lookupSym [Int]
rdepsU, (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
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 =
        ([Int] -> [(String, ([String], [String]))]) -> [[Int]] -> DepCycles
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Int] -> [(String, ([String], [String]))]
lookupSymAndRestrictDeps ([[Int]] -> DepCycles) -> [[Int]] -> DepCycles
forall a b. (a -> b) -> a -> b
$ ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter (\[Int]
xs -> [Int] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) ([[Int]] -> [[Int]]) -> [[Int]] -> [[Int]]
forall a b. (a -> b) -> a -> b
$ (Tree Int -> [Int]) -> [Tree Int] -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Tree Int -> [Int]
forall a. Tree a -> [a]
flatten (Array Int [Int] -> [Tree 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 = ([String], [String])
-> Maybe ([String], [String]) -> ([String], [String])
forall a. a -> Maybe a -> a
fromMaybe ([], []) (Maybe ([String], [String]) -> ([String], [String]))
-> Maybe ([String], [String]) -> ([String], [String])
forall a b. (a -> b) -> a -> b
$ do
  [(String, ([String], [String]))]
cycl <- ([(String, ([String], [String]))] -> Bool)
-> DepCycles -> Maybe [(String, ([String], [String]))]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\[(String, ([String], [String]))]
xs -> String
self String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ((String, ([String], [String])) -> String)
-> [(String, ([String], [String]))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ([String], [String])) -> String
forall a b. (a, b) -> a
fst [(String, ([String], [String]))]
xs) DepCycles
depCycles
  String
-> [(String, ([String], [String]))] -> Maybe ([String], [String])
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 <- ([(String, ([String], [String]))] -> Bool)
-> DepCycles -> Maybe [(String, ([String], [String]))]
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (\[(String, ([String], [String]))]
xs -> String
self String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`L.elem` ((String, ([String], [String])) -> String)
-> [(String, ([String], [String]))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ([String], [String])) -> String
forall a b. (a, b) -> a
fst [(String, ([String], [String]))]
xs) DepCycles
depCycles
  let cyclNoDeps :: [String]
cyclNoDeps = ((String, ([String], [String])) -> String)
-> [(String, ([String], [String]))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String, ([String], [String])) -> String
forall a b. (a, b) -> a
fst [(String, ([String], [String]))]
cycl
  Int
idxSelf <- String
self String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` [String]
cyclNoDeps
  Int
idxImported <- String
imported String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`L.elemIndex` [String]
cyclNoDeps
  (Int, Int) -> Maybe (Int, Int)
forall a. a -> Maybe a
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
  String -> [String]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
d