-- | General utilities useful in the rest of the package
module Build.Utilities (
    -- * Graph operations
    graph, reachable, topSort, reach, reachM
    ) where

import Algebra.Graph
import qualified Algebra.Graph.ToGraph as T

import Data.Either.Extra
import Data.Functor.Identity
import qualified Data.Set as Set

-- | Build a dependency graph given a function for computing dependencies of a
-- key and a target key.
graph :: Ord k => (k -> [k]) -> k -> Graph k
graph :: forall k. Ord k => (k -> [k]) -> k -> Graph k
graph k -> [k]
deps k
key = Graph k -> Graph k
forall a. Graph a -> Graph a
transpose (Graph k -> Graph k) -> Graph k -> Graph k
forall a b. (a -> b) -> a -> b
$ [Graph k] -> Graph k
forall a. [Graph a] -> Graph a
overlays [ k -> [k] -> Graph k
forall a. a -> [a] -> Graph a
star k
k (k -> [k]
deps k
k) | k
k <- Set k -> [k] -> [k]
keys Set k
forall a. Set a
Set.empty [k
key] ]
  where
    keys :: Set k -> [k] -> [k]
keys Set k
seen []   = Set k -> [k]
forall a. Set a -> [a]
Set.toList Set k
seen
    keys Set k
seen (k
x:[k]
xs)
        | k
x k -> Set k -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set k
seen = Set k -> [k] -> [k]
keys Set k
seen [k]
xs
        | Bool
otherwise           = Set k -> [k] -> [k]
keys (k -> Set k -> Set k
forall a. Ord a => a -> Set a -> Set a
Set.insert k
x Set k
seen) (k -> [k]
deps k
x [k] -> [k] -> [k]
forall a. [a] -> [a] -> [a]
++ [k]
xs)

-- | Compute all keys reachable via dependecies from a target key.
reachable :: Ord k => (k -> [k]) -> k -> [k]
reachable :: forall k. Ord k => (k -> [k]) -> k -> [k]
reachable k -> [k]
deps k
key = Graph k -> [k]
forall a. Ord a => Graph a -> [a]
vertexList ((k -> [k]) -> k -> Graph k
forall k. Ord k => (k -> [k]) -> k -> Graph k
graph k -> [k]
deps k
key)

-- | Compute the topological sort of a graph or return @Nothing@ if the graph
-- has cycles.
topSort :: Ord k => Graph k -> Maybe [k]
topSort :: forall k. Ord k => Graph k -> Maybe [k]
topSort = Either (Cycle k) [k] -> Maybe [k]
forall a b. Either a b -> Maybe b
eitherToMaybe (Either (Cycle k) [k] -> Maybe [k])
-> (Graph k -> Either (Cycle k) [k]) -> Graph k -> Maybe [k]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Graph k -> Either (Cycle k) [k]
Graph k -> Either (Cycle (ToVertex (Graph k))) [ToVertex (Graph k)]
forall t.
(ToGraph t, Ord (ToVertex t)) =>
t -> Either (Cycle (ToVertex t)) [ToVertex t]
T.topSort

-- | Given a function to compute successors of a vertex, apply it recursively
-- starting from a given vertex. Returns @Nothing@ if this process does not
-- terminate because of cycles. Note that the current implementation is very
-- inefficient: it trades efficiency for simplicity. The resulting list is
-- likely to contain an exponential number of duplicates.
reach :: Eq a => (a -> [a]) -> a -> Maybe [a]
reach :: forall a. Eq a => (a -> [a]) -> a -> Maybe [a]
reach a -> [a]
successors = Identity (Maybe [a]) -> Maybe [a]
forall a. Identity a -> a
runIdentity (Identity (Maybe [a]) -> Maybe [a])
-> (a -> Identity (Maybe [a])) -> a -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity [a]) -> a -> Identity (Maybe [a])
forall a (m :: * -> *).
(Eq a, Monad m) =>
(a -> m [a]) -> a -> m (Maybe [a])
reachM ([a] -> Identity [a]
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> Identity [a]) -> (a -> [a]) -> a -> Identity [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [a]
successors)

-- | Given a monadic function to compute successors of a vertex, apply it
-- recursively starting from a given vertex. Returns @Nothing@ if this process
-- does not terminate because of cycles. Note that the current implementation is
-- very inefficient: it trades efficiency for simplicity. The resulting list is
-- likely to contain an exponential number of duplicates.
reachM :: (Eq a, Monad m) => (a -> m [a]) -> a -> m (Maybe [a])
reachM :: forall a (m :: * -> *).
(Eq a, Monad m) =>
(a -> m [a]) -> a -> m (Maybe [a])
reachM a -> m [a]
successors a
a = ([a] -> [a]) -> Maybe [a] -> Maybe [a]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
a)) (Maybe [a] -> Maybe [a]) -> m (Maybe [a]) -> m (Maybe [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a] -> a -> m (Maybe [a])
go [] a
a
  where
    go :: [a] -> a -> m (Maybe [a])
go [a]
xs a
x | a
x a -> [a] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [a]
xs = Maybe [a] -> m (Maybe [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [a]
forall a. Maybe a
Nothing -- A cycle is detected
            | Bool
otherwise   = do [Maybe [a]]
res <- (a -> m (Maybe [a])) -> [a] -> m [Maybe [a]]
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 ([a] -> a -> m (Maybe [a])
go (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)) ([a] -> m [Maybe [a]]) -> m [a] -> m [Maybe [a]]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< a -> m [a]
successors a
x
                               Maybe [a] -> m (Maybe [a])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [a] -> m (Maybe [a])) -> Maybe [a] -> m (Maybe [a])
forall a b. (a -> b) -> a -> b
$ ((a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)[a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++) ([a] -> [a]) -> ([[a]] -> [a]) -> [[a]] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[a]] -> [a]) -> Maybe [[a]] -> Maybe [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe [a]] -> Maybe [[a]]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe [a]]
res