diff options
| -rw-r--r-- | lib/CheckDir.hs | 9 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 60 | ||||
| -rw-r--r-- | src/Main.hs | 15 | ||||
| -rw-r--r-- | walint.cabal | 3 |
4 files changed, 60 insertions, 27 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index cb4f886..1f69abf 100644 --- a/lib/CheckDir.hs +++ b/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 } 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 diff --git a/src/Main.hs b/src/Main.hs index 9bc09ff..02e8f02 100644 --- a/src/Main.hs +++ b/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 pretty options then encodePretty lints else encode lints - else printPretty (level, lints) + if | dot options -> + putStrLn (showDot $ dirresultGraph lints) + | json options -> + printLB + $ if pretty options then encodePretty lints else encode lints + | otherwise -> printPretty (level, lints) case out options of Nothing -> exitWith $ case resultIsFatal lintconfig lints of diff --git a/walint.cabal b/walint.cabal index 100a3d0..00b772b 100644 --- a/walint.cabal +++ b/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 |