{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
module SJW.Dependencies (
      Dependencies
    , Failable
    , solve
  ) where

import SJW.Source (Path)
import Control.Monad.Except (MonadError(..))
import Control.Monad.RWS (MonadState, MonadWriter, evalRWST, gets, modify, tell)
import Data.List (intercalate)
import Data.Map (Map, (!))
import qualified Data.Map as Map (adjust, toList)
import Data.Set (Set)
import Text.Printf (printf)

type Dependencies = Map Path (Set Path)
type Failable = MonadError String

solve :: Failable m => Dependencies -> m [Path]
solve :: Dependencies -> m [Path]
solve Dependencies
dependencies = ((), [Path]) -> [Path]
forall a b. (a, b) -> b
snd (((), [Path]) -> [Path]) -> m ((), [Path]) -> m [Path]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST () [Path] State m () -> () -> State -> m ((), [Path])
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST RWST () [Path] State m ()
forall (m :: * -> *). DFSComputation m => m ()
dfs () State
initState
  where
    initState :: State
initState = State :: Map Path (Flag, Set Path) -> [Path] -> State
State {graph :: Map Path (Flag, Set Path)
graph = (,) Flag
New (Set Path -> (Flag, Set Path))
-> Dependencies -> Map Path (Flag, Set Path)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dependencies
dependencies, ariadne :: [Path]
ariadne = []}

data Flag = New | Temporary | Permanent deriving (Flag -> Flag -> Bool
(Flag -> Flag -> Bool) -> (Flag -> Flag -> Bool) -> Eq Flag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Flag -> Flag -> Bool
$c/= :: Flag -> Flag -> Bool
== :: Flag -> Flag -> Bool
$c== :: Flag -> Flag -> Bool
Eq, Eq Flag
Eq Flag
-> (Flag -> Flag -> Ordering)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Bool)
-> (Flag -> Flag -> Flag)
-> (Flag -> Flag -> Flag)
-> Ord Flag
Flag -> Flag -> Bool
Flag -> Flag -> Ordering
Flag -> Flag -> Flag
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Flag -> Flag -> Flag
$cmin :: Flag -> Flag -> Flag
max :: Flag -> Flag -> Flag
$cmax :: Flag -> Flag -> Flag
>= :: Flag -> Flag -> Bool
$c>= :: Flag -> Flag -> Bool
> :: Flag -> Flag -> Bool
$c> :: Flag -> Flag -> Bool
<= :: Flag -> Flag -> Bool
$c<= :: Flag -> Flag -> Bool
< :: Flag -> Flag -> Bool
$c< :: Flag -> Flag -> Bool
compare :: Flag -> Flag -> Ordering
$ccompare :: Flag -> Flag -> Ordering
$cp1Ord :: Eq Flag
Ord)
data State = State {
      State -> Map Path (Flag, Set Path)
graph :: Map Path (Flag, Set Path)
    , State -> [Path]
ariadne :: [Path]
  }

type DFSComputation m = (MonadWriter [Path] m, MonadState State m, MonadError String m)

dfs :: DFSComputation m => m ()
dfs :: m ()
dfs = do
  Maybe (Path, (Flag, Set Path))
maybeNewNode <- (State -> Maybe (Path, (Flag, Set Path)))
-> m (Maybe (Path, (Flag, Set Path)))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ([(Path, (Flag, Set Path))] -> Maybe (Path, (Flag, Set Path))
forall a b. [(a, (Flag, b))] -> Maybe (a, (Flag, b))
popNew ([(Path, (Flag, Set Path))] -> Maybe (Path, (Flag, Set Path)))
-> (State -> [(Path, (Flag, Set Path))])
-> State
-> Maybe (Path, (Flag, Set Path))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Path (Flag, Set Path) -> [(Path, (Flag, Set Path))]
forall k a. Map k a -> [(k, a)]
Map.toList (Map Path (Flag, Set Path) -> [(Path, (Flag, Set Path))])
-> (State -> Map Path (Flag, Set Path))
-> State
-> [(Path, (Flag, Set Path))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Path (Flag, Set Path)
graph)
  case Maybe (Path, (Flag, Set Path))
maybeNewNode of
    Maybe (Path, (Flag, Set Path))
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just (Path, (Flag, Set Path))
newNode -> (Path, (Flag, Set Path)) -> m ()
forall (m :: * -> *).
DFSComputation m =>
(Path, (Flag, Set Path)) -> m ()
visit (Path, (Flag, Set Path))
newNode m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). DFSComputation m => m ()
dfs
  where
    popNew :: [(a, (Flag, b))] -> Maybe (a, (Flag, b))
popNew [] = Maybe (a, (Flag, b))
forall a. Maybe a
Nothing
    popNew ((a
k, v :: (Flag, b)
v@(Flag
New, b
_)):[(a, (Flag, b))]
_) = (a, (Flag, b)) -> Maybe (a, (Flag, b))
forall a. a -> Maybe a
Just (a
k, (Flag, b)
v)
    popNew ((a, (Flag, b))
_:[(a, (Flag, b))]
others) = [(a, (Flag, b))] -> Maybe (a, (Flag, b))
popNew [(a, (Flag, b))]
others

modifyState :: MonadState State m => ((Path, Flag), [Path] -> [Path]) -> m ()
modifyState :: ((Path, Flag), [Path] -> [Path]) -> m ()
modifyState ((Path
path, Flag
flag), [Path] -> [Path]
f) = (State -> State) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((State -> State) -> m ()) -> (State -> State) -> m ()
forall a b. (a -> b) -> a -> b
$ \State
state -> State
state {
      graph :: Map Path (Flag, Set Path)
graph = ((Flag, Set Path) -> (Flag, Set Path))
-> Path -> Map Path (Flag, Set Path) -> Map Path (Flag, Set Path)
forall k a. Ord k => (a -> a) -> k -> Map k a -> Map k a
Map.adjust (\(Flag
_, Set Path
set) -> (Flag
flag, Set Path
set)) Path
path (Map Path (Flag, Set Path) -> Map Path (Flag, Set Path))
-> Map Path (Flag, Set Path) -> Map Path (Flag, Set Path)
forall a b. (a -> b) -> a -> b
$ State -> Map Path (Flag, Set Path)
graph State
state
    , ariadne :: [Path]
ariadne = [Path] -> [Path]
f ([Path] -> [Path]) -> [Path] -> [Path]
forall a b. (a -> b) -> a -> b
$ State -> [Path]
ariadne State
state
  }

visit :: DFSComputation m => (Path, (Flag, Set Path)) -> m ()
visit :: (Path, (Flag, Set Path)) -> m ()
visit (Path
_, (Flag
Permanent, Set Path
_)) = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
visit (Path
loopStart, (Flag
Temporary, Set Path
_)) = do
  [Path]
loop <- (State -> [Path]) -> m [Path]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Path -> Bool) -> [Path] -> [Path]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Path -> Path -> Bool
forall a. Eq a => a -> a -> Bool
/= Path
loopStart) ([Path] -> [Path]) -> (State -> [Path]) -> State -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Path] -> [Path]
forall a. [a] -> [a]
reverse ([Path] -> [Path]) -> (State -> [Path]) -> State -> [Path]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> [Path]
ariadne)
  String -> m ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ [Path] -> String
printLoop [Path]
loop
visit (Path
path, (Flag
New, Set Path
set)) = do
  ((Path, Flag), [Path] -> [Path]) -> m ()
forall (m :: * -> *).
MonadState State m =>
((Path, Flag), [Path] -> [Path]) -> m ()
modifyState ((Path
path, Flag
Temporary), (Path
pathPath -> [Path] -> [Path]
forall a. a -> [a] -> [a]
:))
  (Path -> m ()) -> Set Path -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Path
depPath -> (,) Path
depPath ((Flag, Set Path) -> (Path, (Flag, Set Path)))
-> m (Flag, Set Path) -> m (Path, (Flag, Set Path))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (State -> (Flag, Set Path)) -> m (Flag, Set Path)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((Map Path (Flag, Set Path) -> Path -> (Flag, Set Path)
forall k a. Ord k => Map k a -> k -> a
!Path
depPath) (Map Path (Flag, Set Path) -> (Flag, Set Path))
-> (State -> Map Path (Flag, Set Path))
-> State
-> (Flag, Set Path)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> Map Path (Flag, Set Path)
graph) m (Path, (Flag, Set Path))
-> ((Path, (Flag, Set Path)) -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Path, (Flag, Set Path)) -> m ()
forall (m :: * -> *).
DFSComputation m =>
(Path, (Flag, Set Path)) -> m ()
visit) Set Path
set
  ((Path, Flag), [Path] -> [Path]) -> m ()
forall (m :: * -> *).
MonadState State m =>
((Path, Flag), [Path] -> [Path]) -> m ()
modifyState ((Path
path, Flag
Permanent), (Int -> [Path] -> [Path]
forall a. Int -> [a] -> [a]
drop Int
1))
  [Path] -> m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell [Path
path]

printLoop :: [Path] -> String
printLoop :: [Path] -> String
printLoop [] = String
"Weird dependencies cycle found"
printLoop (Path
path:[Path]
paths) = String
beginning String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Path] -> String
forall p a. PrintfType p => [a] -> p
description [Path]
paths
  where
    beginning :: String
beginning = String
"Dependencies cycle found: "
    description :: [a] -> p
description [] = String -> String -> p
forall r. PrintfType r => String -> r
printf String
"module %s requires itself." (Path -> String
forall a. Show a => a -> String
show Path
path)
    description [a]
_ =
      String -> String -> String -> String -> p
forall r. PrintfType r => String -> r
printf String
"%s requires %s which itself requires %s." String
first String
others String
first
    first :: String
first = Path -> String
forall a. Show a => a -> String
show Path
path
    others :: String
others = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" which requires " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Path -> String
forall a. Show a => a -> String
show (Path -> String) -> [Path] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Path]
paths