72 lines
2.3 KiB
Haskell
72 lines
2.3 KiB
Haskell
{-# 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 = snd <$> evalRWST dfs () initState
|
|
where
|
|
initState = State {graph = (,) New <$> dependencies, ariadne = []}
|
|
|
|
data Flag = New | Temporary | Permanent deriving (Eq, Ord)
|
|
data State = State {
|
|
graph :: Map Path (Flag, Set Path)
|
|
, ariadne :: [Path]
|
|
}
|
|
|
|
type DFSComputation m = (MonadWriter [Path] m, MonadState State m, MonadError String m)
|
|
|
|
dfs :: DFSComputation m => m ()
|
|
dfs = do
|
|
maybeNewNode <- gets (popNew . Map.toList . graph)
|
|
case maybeNewNode of
|
|
Nothing -> return ()
|
|
Just newNode -> visit newNode >> dfs
|
|
where
|
|
popNew [] = Nothing
|
|
popNew ((k, v@(New, _)):_) = Just (k, v)
|
|
popNew (_:others) = popNew others
|
|
|
|
modifyState :: MonadState State m => ((Path, Flag), [Path] -> [Path]) -> m ()
|
|
modifyState ((path, flag), f) = modify $ \state -> state {
|
|
graph = Map.adjust (\(_, set) -> (flag, set)) path $ graph state
|
|
, ariadne = f $ ariadne state
|
|
}
|
|
|
|
visit :: DFSComputation m => (Path, (Flag, Set Path)) -> m ()
|
|
visit (_, (Permanent, _)) = return ()
|
|
visit (loopStart, (Temporary, _)) = do
|
|
loop <- gets (dropWhile (/= loopStart) . reverse . ariadne)
|
|
throwError $ printLoop loop
|
|
visit (path, (New, set)) = do
|
|
modifyState ((path, Temporary), (path:))
|
|
mapM_ (\depPath -> (,) depPath <$> gets ((!depPath) . graph) >>= visit) set
|
|
modifyState ((path, Permanent), (drop 1))
|
|
tell [path]
|
|
|
|
printLoop :: [Path] -> String
|
|
printLoop [] = "Weird dependencies cycle found"
|
|
printLoop (path:paths) = beginning ++ description paths
|
|
where
|
|
beginning = "Dependencies cycle found: "
|
|
description [] = printf "module %s requires itself." (show path)
|
|
description _ =
|
|
printf "%s requires %s which itself requires %s." first others first
|
|
first = show path
|
|
others = intercalate " which requires " $ show <$> paths
|