diff options
Diffstat (limited to 'walint/Dirgraph.hs')
-rw-r--r-- | walint/Dirgraph.hs | 83 |
1 files changed, 83 insertions, 0 deletions
diff --git a/walint/Dirgraph.hs b/walint/Dirgraph.hs new file mode 100644 index 0000000..831933a --- /dev/null +++ b/walint/Dirgraph.hs @@ -0,0 +1,83 @@ +{-# 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 () |