{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Domain.Dependencies
  ( Dependencies,
    Dependency (..),
    getBounds,
    traverseDeps,
    toDependencyList,
    fromDependencyList,
    mergeDependencies,
    normalizeDependencies,
    externalRegistry,
    DependencyGraph (..),
    sortByDependencyHierarchy,
  )
where

import Control.Monad.Error.Class (MonadError (..))
import Data.Aeson
  ( FromJSON (..),
    ToJSON (toJSON),
  )
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import qualified Data.Text as T
import HWM.Core.Formatting (Format (..), formatTable, subPathSign)
import HWM.Core.Parsing (Parse (..), firstWord)
import HWM.Core.Pkg (Pkg (..), PkgName)
import HWM.Core.Result (Issue (..), Severity (..))
import HWM.Domain.Bounds (Bounds, boundsBetter, hasBounds)
import HWM.Runtime.Files (select)
import Relude hiding
  ( Undefined,
    break,
    drop,
    fromList,
    length,
    null,
    show,
    toList,
  )

data Dependency = Dependency
  { Dependency -> PkgName
name :: PkgName,
    Dependency -> Bounds
bounds :: Bounds
  }
  deriving (Int -> Dependency -> ShowS
[Dependency] -> ShowS
Dependency -> String
(Int -> Dependency -> ShowS)
-> (Dependency -> String)
-> ([Dependency] -> ShowS)
-> Show Dependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependency -> ShowS
showsPrec :: Int -> Dependency -> ShowS
$cshow :: Dependency -> String
show :: Dependency -> String
$cshowList :: [Dependency] -> ShowS
showList :: [Dependency] -> ShowS
Show, Dependency -> Dependency -> Bool
(Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Bool) -> Eq Dependency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dependency -> Dependency -> Bool
== :: Dependency -> Dependency -> Bool
$c/= :: Dependency -> Dependency -> Bool
/= :: Dependency -> Dependency -> Bool
Eq)

instance Parse Dependency where
  parse :: forall (m :: * -> *). MonadFail m => Text -> m Dependency
parse =
    (\(Text
name, Text
txt) -> PkgName -> Bounds -> Dependency
Dependency (PkgName -> Bounds -> Dependency)
-> m PkgName -> m (Bounds -> Dependency)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> m PkgName
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m PkgName
parse Text
name m (Bounds -> Dependency) -> m Bounds -> m Dependency
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Text -> m Bounds
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Bounds
parse Text
txt)
      ((Text, Text) -> m Dependency)
-> (Text -> (Text, Text)) -> Text -> m Dependency
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Text, Text)
firstWord

instance Format Dependency where
  format :: Dependency -> Text
format Dependency {PkgName
Bounds
name :: Dependency -> PkgName
bounds :: Dependency -> Bounds
name :: PkgName
bounds :: Bounds
..} = PkgName -> Text
forall a. Format a => a -> Text
format PkgName
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bounds -> Text
forall a. Format a => a -> Text
format Bounds
bounds

newtype Dependencies = Dependencies {Dependencies -> Map PkgName Bounds
unpackDeps :: Map PkgName Bounds}
  deriving (Int -> Dependencies -> ShowS
[Dependencies] -> ShowS
Dependencies -> String
(Int -> Dependencies -> ShowS)
-> (Dependencies -> String)
-> ([Dependencies] -> ShowS)
-> Show Dependencies
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependencies -> ShowS
showsPrec :: Int -> Dependencies -> ShowS
$cshow :: Dependencies -> String
show :: Dependencies -> String
$cshowList :: [Dependencies] -> ShowS
showList :: [Dependencies] -> ShowS
Show)

getBounds :: (MonadError Issue m) => PkgName -> Dependencies -> m Bounds
getBounds :: forall (m :: * -> *).
MonadError Issue m =>
PkgName -> Dependencies -> m Bounds
getBounds PkgName
name = Text -> PkgName -> Map PkgName Bounds -> m Bounds
forall (m :: * -> *) t a.
(MonadError Issue m, Format t, Ord t) =>
Text -> t -> Map t a -> m a
select Text
"Package " PkgName
name (Map PkgName Bounds -> m Bounds)
-> (Dependencies -> Map PkgName Bounds) -> Dependencies -> m Bounds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> Map PkgName Bounds
unpackDeps

traverseDeps :: (Applicative f) => (PkgName -> Bounds -> f Bounds) -> Dependencies -> f Dependencies
traverseDeps :: forall (f :: * -> *).
Applicative f =>
(PkgName -> Bounds -> f Bounds) -> Dependencies -> f Dependencies
traverseDeps PkgName -> Bounds -> f Bounds
f (Dependencies Map PkgName Bounds
xs) = Map PkgName Bounds -> Dependencies
Dependencies (Map PkgName Bounds -> Dependencies)
-> f (Map PkgName Bounds) -> f Dependencies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PkgName -> Bounds -> f Bounds)
-> Map PkgName Bounds -> f (Map PkgName Bounds)
forall (t :: * -> *) k a b.
Applicative t =>
(k -> a -> t b) -> Map k a -> t (Map k b)
Map.traverseWithKey PkgName -> Bounds -> f Bounds
f Map PkgName Bounds
xs

initDependencies :: [Dependency] -> Dependencies
initDependencies :: [Dependency] -> Dependencies
initDependencies = Map PkgName Bounds -> Dependencies
Dependencies (Map PkgName Bounds -> Dependencies)
-> ([Dependency] -> Map PkgName Bounds)
-> [Dependency]
-> Dependencies
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PkgName, Bounds)] -> Map PkgName Bounds
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(PkgName, Bounds)] -> Map PkgName Bounds)
-> ([Dependency] -> [(PkgName, Bounds)])
-> [Dependency]
-> Map PkgName Bounds
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dependency -> (PkgName, Bounds))
-> [Dependency] -> [(PkgName, Bounds)]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> (PkgName, Bounds)
toDuple
  where
    toDuple :: Dependency -> (PkgName, Bounds)
toDuple (Dependency PkgName
a Bounds
b) = (PkgName
a, Bounds
b)

toDependencyList :: Dependencies -> [Dependency]
toDependencyList :: Dependencies -> [Dependency]
toDependencyList (Dependencies Map PkgName Bounds
m) = ((PkgName, Bounds) -> Dependency)
-> [(PkgName, Bounds)] -> [Dependency]
forall a b. (a -> b) -> [a] -> [b]
map ((PkgName -> Bounds -> Dependency)
-> (PkgName, Bounds) -> Dependency
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry PkgName -> Bounds -> Dependency
Dependency) ([(PkgName, Bounds)] -> [Dependency])
-> [(PkgName, Bounds)] -> [Dependency]
forall a b. (a -> b) -> a -> b
$ Map PkgName Bounds -> [(PkgName, Bounds)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PkgName Bounds
m

instance FromJSON Dependencies where
  parseJSON :: Value -> Parser Dependencies
parseJSON Value
v = [Dependency] -> Dependencies
initDependencies ([Dependency] -> Dependencies)
-> Parser [Dependency] -> Parser Dependencies
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Parser [Text]
forall a. FromJSON a => Value -> Parser a
parseJSON Value
v Parser [Text]
-> ([Text] -> Parser [Dependency]) -> Parser [Dependency]
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Parser Dependency) -> [Text] -> Parser [Dependency]
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) -> [a] -> f [b]
traverse Text -> Parser Dependency
forall a (m :: * -> *). (Parse a, MonadFail m) => Text -> m a
forall (m :: * -> *). MonadFail m => Text -> m Dependency
parse ([Text] -> Parser [Dependency])
-> ([Text] -> [Text]) -> [Text] -> Parser [Dependency]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. Ord a => [a] -> [a]
sort)

instance ToJSON Dependencies where
  toJSON :: Dependencies -> Value
toJSON = [Text] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Text] -> Value)
-> (Dependencies -> [Text]) -> Dependencies -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
formatTable ([Text] -> [Text])
-> (Dependencies -> [Text]) -> Dependencies -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dependency -> Text) -> [Dependency] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> Text
forall a. Format a => a -> Text
format ([Dependency] -> [Text])
-> (Dependencies -> [Dependency]) -> Dependencies -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependencies -> [Dependency]
toDependencyList

fromDependencyList :: [Dependency] -> Dependencies
fromDependencyList :: [Dependency] -> Dependencies
fromDependencyList = [Dependency] -> Dependencies
initDependencies

mergeDependencies :: [Dependency] -> [Dependency]
mergeDependencies :: [Dependency] -> [Dependency]
mergeDependencies = Map PkgName Dependency -> [Dependency]
forall k a. Map k a -> [a]
Map.elems (Map PkgName Dependency -> [Dependency])
-> ([Dependency] -> Map PkgName Dependency)
-> [Dependency]
-> [Dependency]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map PkgName Dependency -> Dependency -> Map PkgName Dependency)
-> Map PkgName Dependency -> [Dependency] -> Map PkgName Dependency
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PkgName Dependency -> Dependency -> Map PkgName Dependency
step Map PkgName Dependency
forall k a. Map k a
Map.empty
  where
    step :: Map PkgName Dependency -> Dependency -> Map PkgName Dependency
step Map PkgName Dependency
acc Dependency
dep =
      (Dependency -> Dependency -> Dependency)
-> PkgName
-> Dependency
-> Map PkgName Dependency
-> Map PkgName Dependency
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith Dependency -> Dependency -> Dependency
prefer (Dependency -> PkgName
name Dependency
dep) Dependency
dep Map PkgName Dependency
acc
    prefer :: Dependency -> Dependency -> Dependency
prefer Dependency
new Dependency
old = if Bounds -> Bounds -> Bool
boundsBetter (Dependency -> Bounds
bounds Dependency
new) (Dependency -> Bounds
bounds Dependency
old) then Dependency
new else Dependency
old

normalizeDependencies :: [Dependency] -> [Dependency]
normalizeDependencies :: [Dependency] -> [Dependency]
normalizeDependencies = (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bounds -> Bool
hasBounds (Bounds -> Bool) -> (Dependency -> Bounds) -> Dependency -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dependency -> Bounds
bounds) ([Dependency] -> [Dependency])
-> ([Dependency] -> [Dependency]) -> [Dependency] -> [Dependency]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Dependency] -> [Dependency]
mergeDependencies

externalRegistry :: [PkgName] -> [Dependency] -> Dependencies
externalRegistry :: [PkgName] -> [Dependency] -> Dependencies
externalRegistry [PkgName]
internalPkgs [Dependency]
deps =
  let externals :: [Dependency]
externals = (Dependency -> Bool) -> [Dependency] -> [Dependency]
forall a. (a -> Bool) -> [a] -> [a]
filter Dependency -> Bool
isExternal ([Dependency] -> [Dependency]
normalizeDependencies [Dependency]
deps)
   in [Dependency] -> Dependencies
fromDependencyList ((Dependency -> PkgName) -> [Dependency] -> [Dependency]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn Dependency -> PkgName
name [Dependency]
externals)
  where
    internals :: Set PkgName
internals = [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList [PkgName]
internalPkgs
    isExternal :: Dependency -> Bool
isExternal Dependency
dep = Bool -> Bool
not (PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Dependency -> PkgName
name Dependency
dep) Set PkgName
internals)

newtype DependencyGraph = DependencyGraph (Map PkgName [PkgName])

instance Format DependencyGraph where
  format :: DependencyGraph -> Text
format DependencyGraph
graph = Text -> [Text] -> Text
T.intercalate Text
"\n" ((Tree -> Text) -> [Tree] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Tree -> Text
formatTree Int
0) (DependencyGraph -> [Tree]
toTree DependencyGraph
graph))

formatTree :: Int -> Tree -> Text
formatTree :: Int -> Tree -> Text
formatTree Int
depth (Node PkgName
pkg [Tree]
deps) = Text
newLine Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PkgName -> Text
forall a. Format a => a -> Text
format PkgName
pkg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
children
  where
    newLine :: Text
newLine | Int
depth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Text
"\n    • " | Bool
otherwise = Text
"\n  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate Int
depth Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
subPathSign
    children :: Text
children = Text -> [Text] -> Text
T.intercalate Text
"" ((Tree -> Text) -> [Tree] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Tree -> Text
formatTree (Int
depth Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [Tree]
deps)

data Tree = Node PkgName [Tree]

toTree :: DependencyGraph -> [Tree]
toTree :: DependencyGraph -> [Tree]
toTree (DependencyGraph Map PkgName [PkgName]
graph) =
  let allPkgs :: Set PkgName
allPkgs = Map PkgName [PkgName] -> Set PkgName
forall k a. Map k a -> Set k
Map.keysSet Map PkgName [PkgName]
graph Set PkgName -> Set PkgName -> Set PkgName
forall a. Semigroup a => a -> a -> a
<> ([PkgName] -> Set PkgName) -> [[PkgName]] -> Set PkgName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList (Map PkgName [PkgName] -> [[PkgName]]
forall k a. Map k a -> [a]
Map.elems Map PkgName [PkgName]
graph)
      dependentPkgs :: Set PkgName
dependentPkgs = ([PkgName] -> Set PkgName) -> [[PkgName]] -> Set PkgName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList (Map PkgName [PkgName] -> [[PkgName]]
forall k a. Map k a -> [a]
Map.elems Map PkgName [PkgName]
graph)
      rootPkgs :: [PkgName]
rootPkgs = Set PkgName -> [PkgName]
forall a. Set a -> [a]
Set.toList (Set PkgName -> Set PkgName -> Set PkgName
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set PkgName
allPkgs Set PkgName
dependentPkgs)
   in (PkgName -> Tree) -> [PkgName] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map (Map PkgName [PkgName] -> Set PkgName -> PkgName -> Tree
buildTree Map PkgName [PkgName]
graph Set PkgName
forall a. Set a
Set.empty) [PkgName]
rootPkgs

buildTree :: Map PkgName [PkgName] -> Set PkgName -> PkgName -> Tree
buildTree :: Map PkgName [PkgName] -> Set PkgName -> PkgName -> Tree
buildTree Map PkgName [PkgName]
graph Set PkgName
visited PkgName
pkg =
  if PkgName -> Set PkgName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member PkgName
pkg Set PkgName
visited
    then PkgName -> [Tree] -> Tree
Node PkgName
pkg []
    else
      let deps :: [PkgName]
deps = [PkgName] -> PkgName -> Map PkgName [PkgName] -> [PkgName]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PkgName
pkg Map PkgName [PkgName]
graph
          newVisited :: Set PkgName
newVisited = PkgName -> Set PkgName -> Set PkgName
forall a. Ord a => a -> Set a -> Set a
Set.insert PkgName
pkg Set PkgName
visited
          childTrees :: [Tree]
childTrees = (PkgName -> Tree) -> [PkgName] -> [Tree]
forall a b. (a -> b) -> [a] -> [b]
map (Map PkgName [PkgName] -> Set PkgName -> PkgName -> Tree
buildTree Map PkgName [PkgName]
graph Set PkgName
newVisited) [PkgName]
deps
       in PkgName -> [Tree] -> Tree
Node PkgName
pkg [Tree]
childTrees

topologicalSort :: DependencyGraph -> Either [PkgName] [PkgName]
topologicalSort :: DependencyGraph -> Either [PkgName] [PkgName]
topologicalSort (DependencyGraph Map PkgName [PkgName]
graph) = [PkgName]
-> Set PkgName -> Map PkgName Int -> Either [PkgName] [PkgName]
forall {a}.
(Ord a, Num a) =>
[PkgName]
-> Set PkgName -> Map PkgName a -> Either [PkgName] [PkgName]
goFunc [] Set PkgName
initialZero Map PkgName Int
indegreeMap
  where
    nodes :: Set PkgName
nodes = Map PkgName [PkgName] -> Set PkgName
forall k a. Map k a -> Set k
Map.keysSet Map PkgName [PkgName]
graph Set PkgName -> Set PkgName -> Set PkgName
forall a. Semigroup a => a -> a -> a
<> ([PkgName] -> Set PkgName) -> [[PkgName]] -> Set PkgName
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList (Map PkgName [PkgName] -> [[PkgName]]
forall k a. Map k a -> [a]
Map.elems Map PkgName [PkgName]
graph)
    indegreeMap :: Map PkgName Int
indegreeMap = (Map PkgName Int -> (PkgName, [PkgName]) -> Map PkgName Int)
-> Map PkgName Int -> [(PkgName, [PkgName])] -> Map PkgName Int
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map PkgName Int -> (PkgName, [PkgName]) -> Map PkgName Int
forall {t :: * -> *} {a} {a} {a}.
(Foldable t, Ord a, Num a) =>
Map a a -> (a, t a) -> Map a a
updateIndegree Map PkgName Int
baseIndegree (Map PkgName [PkgName] -> [(PkgName, [PkgName])]
forall k a. Map k a -> [(k, a)]
Map.toList Map PkgName [PkgName]
graph)
    baseIndegree :: Map PkgName Int
baseIndegree = (PkgName -> Int) -> Set PkgName -> Map PkgName Int
forall k a. (k -> a) -> Set k -> Map k a
Map.fromSet (Int -> PkgName -> Int
forall a b. a -> b -> a
const (Int
0 :: Int)) Set PkgName
nodes
    updateIndegree :: Map a a -> (a, t a) -> Map a a
updateIndegree Map a a
acc (a
_, t a
deps) = (Map a a -> a -> Map a a) -> Map a a -> t a -> Map a a
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map a a -> a -> Map a a
forall {k} {a}. (Ord k, Num a) => Map k a -> k -> Map k a
increment Map a a
acc t a
deps
    increment :: Map k a -> k -> Map k a
increment Map k a
acc k
dep = (a -> a -> a) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith a -> a -> a
forall a. Num a => a -> a -> a
(+) k
dep a
1 Map k a
acc
    initialZero :: Set PkgName
initialZero = [PkgName] -> Set PkgName
forall a. Ord a => [a] -> Set a
Set.fromList [PkgName
pkg | (PkgName
pkg, Int
deg) <- Map PkgName Int -> [(PkgName, Int)]
forall k a. Map k a -> [(k, a)]
Map.toList Map PkgName Int
indegreeMap, Int
deg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0]

    goFunc :: [PkgName]
-> Set PkgName -> Map PkgName a -> Either [PkgName] [PkgName]
goFunc [PkgName]
acc Set PkgName
zeros Map PkgName a
indegrees
      | Set PkgName -> Bool
forall a. Set a -> Bool
Set.null Set PkgName
zeros =
          case Map PkgName a -> [PkgName]
forall k a. Map k a -> [k]
Map.keys ((a -> Bool) -> Map PkgName a -> Map PkgName a
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0) Map PkgName a
indegrees) of
            [] -> [PkgName] -> Either [PkgName] [PkgName]
forall a b. b -> Either a b
Right ([PkgName] -> [PkgName]
forall a. [a] -> [a]
reverse [PkgName]
acc)
            [PkgName]
cycleNodes -> [PkgName] -> Either [PkgName] [PkgName]
forall a b. a -> Either a b
Left [PkgName]
cycleNodes
      | Bool
otherwise =
          let (PkgName
pkg, Set PkgName
remainingZeros) = Set PkgName -> (PkgName, Set PkgName)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set PkgName
zeros
              neighbours :: [PkgName]
neighbours = [PkgName] -> PkgName -> Map PkgName [PkgName] -> [PkgName]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] PkgName
pkg Map PkgName [PkgName]
graph
              (Set PkgName
nextZeros, Map PkgName a
nextIndegrees) = ((Set PkgName, Map PkgName a)
 -> PkgName -> (Set PkgName, Map PkgName a))
-> (Set PkgName, Map PkgName a)
-> [PkgName]
-> (Set PkgName, Map PkgName a)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Set PkgName, Map PkgName a)
-> PkgName -> (Set PkgName, Map PkgName a)
forall {a} {p}.
(Num a, Ord p, Eq a) =>
(Set p, Map p a) -> p -> (Set p, Map p a)
reduce (Set PkgName
remainingZeros, Map PkgName a
indegrees) [PkgName]
neighbours
           in [PkgName]
-> Set PkgName -> Map PkgName a -> Either [PkgName] [PkgName]
goFunc (PkgName
pkg PkgName -> [PkgName] -> [PkgName]
forall a. a -> [a] -> [a]
: [PkgName]
acc) Set PkgName
nextZeros Map PkgName a
nextIndegrees

    reduce :: (Set p, Map p a) -> p -> (Set p, Map p a)
reduce (Set p
zeros, Map p a
indegrees) p
neighbour =
      let deg :: a
deg = a -> p -> Map p a -> a
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault a
0 p
neighbour Map p a
indegrees a -> a -> a
forall a. Num a => a -> a -> a
- a
1
          updatedIndegrees :: Map p a
updatedIndegrees = p -> a -> Map p a -> Map p a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert p
neighbour a
deg Map p a
indegrees
          updatedZeros :: Set p
updatedZeros = if a
deg a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then p -> Set p -> Set p
forall a. Ord a => a -> Set a -> Set a
Set.insert p
neighbour Set p
zeros else Set p
zeros
       in (Set p
updatedZeros, Map p a
updatedIndegrees)

sortByDependencyHierarchy :: (MonadError Issue m) => DependencyGraph -> [Pkg] -> m [Pkg]
sortByDependencyHierarchy :: forall (m :: * -> *).
MonadError Issue m =>
DependencyGraph -> [Pkg] -> m [Pkg]
sortByDependencyHierarchy DependencyGraph
graph [Pkg]
ns = do
  case DependencyGraph -> Either [PkgName] [PkgName]
topologicalSort DependencyGraph
graph of
    Left [PkgName]
depCycle ->
      let cycleNames :: String
cycleNames = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ((PkgName -> String) -> [PkgName] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map PkgName -> String
forall a. ToString a => a -> String
toString [PkgName]
depCycle)
       in Issue -> m [Pkg]
forall a. Issue -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
            Issue
              { issueTopic :: Text
issueTopic = Text
"dependency-resolution",
                issueSeverity :: Severity
issueSeverity = Severity
SeverityError,
                issueMessage :: Text
issueMessage = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String
"Dependency cycle detected: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
cycleNames,
                issueDetails :: Maybe IssueDetails
issueDetails = Maybe IssueDetails
forall a. Maybe a
Nothing
              }
    Right [PkgName]
sortedNames ->
      let indexes :: Map PkgName Int
indexes = [(PkgName, Int)] -> Map PkgName Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([PkgName] -> [Int] -> [(PkgName, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [PkgName]
sortedNames [Int
0 ..] :: [(PkgName, Int)])
          findIndex :: Pkg -> Int
findIndex Pkg
pkg = Int -> PkgName -> Map PkgName Int -> Int
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault Int
forall a. Bounded a => a
maxBound (Pkg -> PkgName
pkgName Pkg
pkg) Map PkgName Int
indexes
       in [Pkg] -> m [Pkg]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Pkg] -> m [Pkg]) -> [Pkg] -> m [Pkg]
forall a b. (a -> b) -> a -> b
$ (Pkg -> Down Int) -> [Pkg] -> [Pkg]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int -> Down Int
forall a. a -> Down a
Down (Int -> Down Int) -> (Pkg -> Int) -> Pkg -> Down Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> Int
findIndex) [Pkg]
ns