diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Dirgraph.hs | 49 |
1 files changed, 49 insertions, 0 deletions
diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs new file mode 100644 index 0000000..0931ea0 --- /dev/null +++ b/lib/Dirgraph.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Simple directed graphs, for dependency checking +module Dirgraph where + + +import CheckMap (MapResult (mapresultDepends)) +import Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey) +import qualified Data.Map.Strict as M +import Data.Set (Set, (\\)) +import qualified Data.Set as S +import Paths (normalise) +import Types (Dep (LocalMap)) +import Witherable (mapMaybe) + +-- | a simple directed graph +type Graph a = Map a (Set a) + +nodes :: Graph a -> Set a +nodes = M.keysSet + +-- | simple directed graph of exits +resultToGraph :: Map FilePath MapResult -> Graph FilePath +resultToGraph = fmap (S.fromList . mapMaybe onlyLocalMaps . mapresultDepends) + where onlyLocalMaps = \case + LocalMap path -> Just (normalise "" path) + _ -> Nothing + +-- | invert edges of a directed graph +invertGraph :: (Eq a, Ord a) => Graph a -> Graph a +invertGraph graph = mapWithKey collectFroms graph + where collectFroms to _ = S.fromList . M.elems . mapMaybeWithKey (select to) $ graph + select to from elems = if to `elem` elems then Just from else Nothing + +-- | all nodes reachable from some entrypoint +reachableFrom :: Ord a => a -> Graph a -> Set a +reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint) + where recursive seen current + | null current = seen + | otherwise = recursive (S.union seen current) (next \\ seen) + where next = S.unions + . S.fromList -- for some reason set is not filterable? + . mapMaybe (`M.lookup` graph) + . S.toList + $ current + +unreachableFrom :: Ord a => a -> Graph a -> Set a +unreachableFrom entrypoint graph = + nodes graph \\ reachableFrom entrypoint graph |