diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/CheckDir.hs | 10 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 22 |
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 () |