simple graphviz visualisation of a repository

might be useful to have

2 files changed, 27 insertions, 5 deletions

diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs
index 0011857..1cfd753 100644
--- a/lib/CheckDir.hs
+++ b/lib/CheckDir.hs
@@ -23,7 +23,7 @@ import           Data.Map.Strict        (mapKeys, (\\))
 import           Data.Maybe             (mapMaybe)
 import           Data.Text              (Text)
 import qualified Data.Text              as T
-import           Dirgraph               (invertGraph, resultToGraph,
+import           Dirgraph               (graphToDot, invertGraph, resultToGraph,
                                          unreachableFrom)
 import           GHC.Generics           (Generic)
 import           LintConfig             (LintConfig', configMaxLintLevel)
@@ -32,6 +32,7 @@ import           System.Directory.Extra (doesFileExist)
 import           System.FilePath        (splitPath, (</>))
 import qualified System.FilePath        as FP
 import           System.FilePath.Posix  (takeDirectory)
+import           Text.Dot               (Dot, showDot)
 import           Types                  (Dep (Local, LocalMap), Hint (Hint),
                                          Level (..), hintLevel)
 import           Util                   (PrettyPrint (prettyprint))
@@ -53,6 +54,7 @@ data DirResult = DirResult
   -- ^ all dependencies to things outside this repository
   , dirresultMissingAssets :: [MissingAsset]
   -- ^ entrypoints of maps which are referred to but missing
+  , dirresultGraph         :: Dot ()
   } deriving (Generic)
 
 data MissingDep = MissingDep
@@ -96,6 +98,7 @@ instance ToJSON DirResult where
       [ "missingDeps" .= dirresultDeps res
       , "missingAssets" .= dirresultMissingAssets res
       , "mapLints" .= dirresultMaps res
+      , "exitGraph" .= showDot (dirresultGraph res)
       ]
     , "resultText" .= prettyprint (Suggestion, res)
     , "severity" .= maximumLintLevel res
@@ -145,12 +148,12 @@ recursiveCheckDir
 recursiveCheckDir config prefix root = do
   maps <- recursiveCheckDir' config prefix [root] mempty
 
+  let exitGraph = resultToGraph maps
   -- maps that don't have (local) ways back to the main entrypoint
   let nowayback =
         unreachableFrom root
         . invertGraph
-        . resultToGraph
-        $ maps
+        $ exitGraph
 
   -- inject warnings for maps that have no way back to the entrypoint
   let maps' = flip mapWithKey maps $ \path res ->
@@ -165,6 +168,7 @@ recursiveCheckDir config prefix root = do
   pure $ DirResult { dirresultDeps = missingDeps root maps'
                    , dirresultMissingAssets = mAssets
                    , dirresultMaps = maps'
+                   , dirresultGraph = graphToDot exitGraph
                    }
 
 
diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs
index 0931ea0..b97a644 100644
--- a/lib/Dirgraph.hs
+++ b/lib/Dirgraph.hs
@@ -1,15 +1,21 @@
-{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE LambdaCase    #-}
+{-# LANGUAGE TupleSections #-}
 
 -- | Simple directed graphs, for dependency checking
 module Dirgraph where
 
 
 import           CheckMap        (MapResult (mapresultDepends))
-import           Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey)
+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)
 
@@ -47,3 +53,15 @@ reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint)
 unreachableFrom :: Ord a => a -> Graph a -> Set a
 unreachableFrom entrypoint graph =
   nodes graph \\ reachableFrom entrypoint graph
+
+graphToDot :: Graph FilePath -> Dot ()
+graphToDot graph = do
+  nodes <- traverseWithKey
+    (\name edges -> D.node [("label",name)] <&> (,edges))
+    graph
+
+  forM_ nodes $ \(node, edges) ->
+    forM_ edges $ \key ->
+      case M.lookup key nodes of
+        Just (other,_) -> node .->. other
+        _              -> pure ()