From 8f292660630b3154a3441cc673d6aa605f668e5b Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Thu, 30 Dec 2021 23:35:10 +0100
Subject: add dot language output for repository map graphs

---
 lib/Dirgraph.hs | 60 ++++++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 42 insertions(+), 18 deletions(-)

(limited to 'lib/Dirgraph.hs')

diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs
index b97a644..8d4a5f2 100644
--- a/lib/Dirgraph.hs
+++ b/lib/Dirgraph.hs
@@ -5,19 +5,22 @@
 module Dirgraph where
 
 
-import           CheckMap        (MapResult (mapresultDepends))
-import           Control.Monad   (forM_)
-import           Data.Functor    ((<&>))
-import           Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey,
-                                  traverseWithKey)
-import qualified Data.Map.Strict as M
-import           Data.Set        (Set, (\\))
-import qualified Data.Set        as S
-import           Paths           (normalise)
-import           Text.Dot        (Dot, (.->.))
-import qualified Text.Dot        as D
-import           Types           (Dep (LocalMap))
-import           Witherable      (mapMaybe)
+import           CheckMap              (MapResult (mapresultDepends))
+import           Control.Monad         (forM_, unless)
+import           Data.Functor          ((<&>))
+import           Data.Map.Strict       (Map, mapMaybeWithKey, mapWithKey,
+                                        traverseMaybeWithKey, traverseWithKey)
+import qualified Data.Map.Strict       as M
+import           Data.Maybe            (fromMaybe)
+import           Data.Set              (Set, (\\))
+import qualified Data.Set              as S
+import           Paths                 (normalise)
+import qualified System.FilePath       as FP
+import           System.FilePath.Posix (takeDirectory, (</>))
+import           Text.Dot              (Dot, (.->.))
+import qualified Text.Dot              as D
+import           Types                 (Dep (LocalMap))
+import           Witherable            (mapMaybe)
 
 -- | a simple directed graph
 type Graph a = Map a (Set a)
@@ -27,9 +30,11 @@ 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)
+resultToGraph = mapWithKey (\p r -> S.fromList
+                             . mapMaybe (onlyLocalMaps (takeDirectory p))
+                             . mapresultDepends $ r)
+  where onlyLocalMaps prefix = \case
+          LocalMap path -> Just (FP.normalise (prefix </> normalise "" path))
           _             -> Nothing
 
 -- | invert edges of a directed graph
@@ -54,12 +59,31 @@ 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
-  nodes <- traverseWithKey
-    (\name edges -> D.node [("label",name)] <&> (,edges))
+  main <- D.node [("label","main.json")]
+  nodes' <- 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
-- 
cgit v1.2.3