add dot language output for repository map graphs

lib/CheckDir.hs

@@ -25,7 +25,7 @@ import           Data.Maybe             (isJust, mapMaybe)
 import           Data.Text              (Text, isInfixOf)
 import qualified Data.Text              as T
 import           Dirgraph               (graphToDot, invertGraph, resultToGraph,
-                                         unreachableFrom)
+                                         takeSubGraph, unreachableFrom)
 import           GHC.Generics           (Generic)
 import           LintConfig             (LintConfig', configMaxLintLevel)
 import           Paths                  (normalise, normaliseWithFrag)
@@ -107,7 +107,7 @@ instance ToJSON DirResult where
                        . M.toList
                        $ dirresultMaps res)
       -- unused in the hub, temporarily removed to make the output smaller
-      -- , "exitGraph" .= showDot (dirresultGraph res)
+      , "exitGraph" .= showDot (dirresultGraph res)
       ]
     , "severity" .= maximumLintLevel res
     , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ])
@@ -178,7 +178,10 @@ recursiveCheckDir config prefix root = do
   pure $ DirResult { dirresultDeps = missingDeps root maps'
                    , dirresultMissingAssets = mAssets
                    , dirresultMaps = maps'
-                   , dirresultGraph = graphToDot exitGraph
+                   , dirresultGraph =
+                     graphToDot
+                     . takeSubGraph 7 root
+                     $ exitGraph
                    }
 
 

lib/Dirgraph.hs

@@ -6,14 +6,17 @@ module Dirgraph where
 
 
 import           CheckMap              (MapResult (mapresultDepends))
-import           Control.Monad   (forM_)
+import           Control.Monad         (forM_, unless)
 import           Data.Functor          ((<&>))
 import           Data.Map.Strict       (Map, mapMaybeWithKey, mapWithKey,
-                                  traverseWithKey)
+                                        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))
@@ -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

src/Main.hs

@@ -3,6 +3,7 @@
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE MultiWayIf #-}
 
 module Main where
 
@@ -18,7 +19,7 @@ import qualified Data.Text.IO             as T
 import           System.Exit              (ExitCode (..), exitWith)
 import           WithCli
 
-import           CheckDir                 (recursiveCheckDir, resultIsFatal)
+import           CheckDir                 (recursiveCheckDir, resultIsFatal, DirResult (dirresultGraph))
 import           Control.Monad            (when)
 import           LintConfig               (LintConfig (..), patchConfig)
 import           System.IO                (hPutStrLn, stderr)
@@ -26,6 +27,7 @@ import           Types                    (Level (..))
 import           Util                     (printPretty)
 import qualified Version                  as V (version)
 import           WriteRepo                (writeAdjustedRepository)
+import Text.Dot (showDot)
 
 -- | the options this cli tool can take
 data Options = Options
@@ -46,6 +48,7 @@ data Options = Options
   , config     :: Maybe (LintConfig Maybe)
   -- ^ a "patch" for the configuration file
   , version    :: Bool
+  , dot        :: Bool
   } deriving (Show, Generic, HasArguments)
 
 
@@ -73,10 +76,12 @@ run options = do
 
   lints <- recursiveCheckDir lintconfig repo entry
 
-  if json options
-    then printLB
+  if | dot options ->
+       putStrLn (showDot $ dirresultGraph lints)
+     | json options ->
+       printLB
         $ if pretty options then encodePretty lints else encode lints
-    else printPretty (level, lints)
+     | otherwise -> printPretty (level, lints)
 
   case out options of
     Nothing -> exitWith $ case resultIsFatal lintconfig lints of

walint.cabal

@@ -72,7 +72,8 @@ executable walint
                       mtl,
                       text,
                       template-haskell,
-                      process
+                      process,
+                      dotgen
     hs-source-dirs:   src
     default-language: Haskell2010
     other-modules: Version