summaryrefslogtreecommitdiff
path: root/lib/Dirgraph.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Dirgraph.hs')
-rw-r--r--lib/Dirgraph.hs84
1 files changed, 0 insertions, 84 deletions
diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs
deleted file mode 100644
index cc140a3..0000000
--- a/lib/Dirgraph.hs
+++ /dev/null
@@ -1,84 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE TupleSections #-}
-
--- | Simple directed graphs, for dependency checking
-module Dirgraph where
-
-import Universum
-
-import CheckMap (MapResult (mapresultDepends))
-import Data.Map.Strict (mapMaybeWithKey, mapWithKey)
-import qualified Data.Map.Strict as M
-import Data.Set ((\\))
-import qualified Data.Set as S
-import Paths (normalise)
-import qualified Text.Dot as D
-import Text.Dot (Dot, (.->.))
-import Types (Dep (LocalMap))
-
--- | 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 a) -> 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 . 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
-
-takeSubGraph :: (Eq a, Ord a) => Int -> a -> Graph a -> Graph a
-takeSubGraph i start graph
- | i <= 0 = mempty
- | i == 1 =
- M.singleton start reachable
- `M.union` M.fromList ((,mempty) <$> S.toList reachable)
- | otherwise =
- M.singleton start reachable
- `M.union` (M.unionsWith S.union
- . S.map (flip (takeSubGraph (i-1)) graph)
- $ reachable)
- where reachable = fromMaybe mempty (M.lookup start graph)
-
-graphToDot :: Graph FilePath -> Dot ()
-graphToDot graph = do
- main <- D.node [("label","main.json")]
- nodes' <- M.traverseMaybeWithKey
- (\name edges -> if name /= "main.json"
- then D.node [("label",name)] <&> (, edges) <&> Just
- else pure Nothing
- )
- graph
-
- let reachable = fromMaybe mempty (M.lookup "main.json" graph)
- let nodes = M.insert "main.json" (main,reachable) nodes'
- forM_ nodes $ \(node, edges) ->
- forM_ edges $ \key ->
- case M.lookup key nodes of
- Just (other,_) -> node .->. other
- _ -> pure ()