diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/CheckDir.hs | 138 | ||||
| -rw-r--r-- | lib/Dirgraph.hs | 49 |
2 files changed, 120 insertions, 67 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index d6a7bd5..0011857 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -23,6 +23,8 @@ import Data.Map.Strict (mapKeys, (\\)) import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T +import Dirgraph (invertGraph, resultToGraph, + unreachableFrom) import GHC.Generics (Generic) import LintConfig (LintConfig', configMaxLintLevel) import Paths (normalise, normaliseWithFrag) @@ -30,8 +32,8 @@ import System.Directory.Extra (doesFileExist) import System.FilePath (splitPath, (</>)) import qualified System.FilePath as FP import System.FilePath.Posix (takeDirectory) -import Types (Dep (Local, LocalMap), Level (..), - hintLevel) +import Types (Dep (Local, LocalMap), Hint (Hint), + Level (..), hintLevel) import Util (PrettyPrint (prettyprint)) @@ -132,39 +134,44 @@ instance PrettyPrint MissingDep where T.intercalate "," $ map T.pack n -instance Semigroup DirResult where - a <> b = DirResult - { dirresultMaps = dirresultMaps a <> dirresultMaps b - , dirresultDeps = dirresultDeps a <> dirresultDeps b - , dirresultMissingAssets = - dirresultMissingAssets a <> dirresultMissingAssets b - } - -instance Monoid DirResult where - mempty = DirResult - { dirresultMaps = mempty - , dirresultDeps = mempty - , dirresultMissingAssets = mempty - } - - --- | The nice function to check an entire repository with. --- gets a prefix (i.e. the bare path to the repository) and --- a root (i.e. the name of the file containing the entrypoint --- map within that file) -recursiveCheckDir :: LintConfig' -> FilePath -> FilePath -> IO DirResult +-- | check an entire repository +recursiveCheckDir + :: LintConfig' + -> FilePath + -- ^ the repository's prefix (i.e. path to its directory) + -> FilePath + -- ^ the repository's entrypoint (filename of a map, from the repo's root) + -> IO DirResult recursiveCheckDir config prefix root = do - linted <- recursiveCheckDir' config prefix [root] mempty mempty - mAssets <- missingAssets prefix linted - pure $ linted <> mempty { dirresultDeps = missingDeps root linted - , dirresultMissingAssets = mAssets - } + maps <- recursiveCheckDir' config prefix [root] mempty + + -- maps that don't have (local) ways back to the main entrypoint + let nowayback = + unreachableFrom root + . invertGraph + . resultToGraph + $ maps + + -- inject warnings for maps that have no way back to the entrypoint + let maps' = flip mapWithKey maps $ \path res -> + if path `elem` nowayback + then res { mapresultGeneral = + Hint Warning ("Cannot go back to " <> T.pack root <> " from this map.") + : mapresultGeneral res + } + else res + + mAssets <- missingAssets prefix maps' + pure $ DirResult { dirresultDeps = missingDeps root maps' + , dirresultMissingAssets = mAssets + , dirresultMaps = maps' + } -- | Given a (partially) completed DirResult, check which local -- maps are referenced but do not actually exist. -missingDeps :: FilePath -> DirResult -> [MissingDep] -missingDeps entrypoint res = +missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep] +missingDeps entrypoint maps = let simple = M.insert (T.pack entrypoint) [] used \\ M.union defined trivial in M.foldMapWithKey (\f n -> [MissingDep f n]) simple where @@ -173,7 +180,7 @@ missingDeps entrypoint res = used = M.fromList $ M.foldMapWithKey (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) - (dirresultMaps res) + maps where extractLocalDeps prefix = \case LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name _ -> Nothing @@ -182,15 +189,14 @@ missingDeps entrypoint res = defined = setFromList $ M.foldMapWithKey (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v) - (dirresultMaps res) + maps -- each map file is an entrypoint by itself - trivial = mapKeys T.pack $ void (dirresultMaps res) + trivial = mapKeys T.pack $ void maps --- | Checks if all assets found (contained in the map's lints) --- actually exist where they should exist -missingAssets :: FilePath -> DirResult -> IO [MissingAsset] -missingAssets prefix res = - mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList . dirresultMaps $ res) <&> fold +-- | Checks if all assets referenced in the result actually exist as files +missingAssets :: FilePath -> Map FilePath MapResult -> IO [MissingAsset] +missingAssets prefix maps = + mapM (fmap (fmap (fmap MissingAsset)) missingOfMap) (M.toList maps) <&> fold where missingOfMap (path, mapres) = mapMaybeM (\case Local relpath -> let asset = normalise (takeDirectory path) relpath @@ -201,13 +207,17 @@ missingAssets prefix res = (mapresultDepends mapres) --- | The less-nice function for checking an entire repository. --- --- Strictly speaking it probably doesn't need to have `done` and --- `acc` since they are essentially the same thing, but doing it --- like this seemed convenient at the time -recursiveCheckDir' :: LintConfig' -> FilePath -> [FilePath] -> Set FilePath -> DirResult -> IO DirResult -recursiveCheckDir' config prefix paths done acc = do +-- | recursive checking of all maps in a repository +recursiveCheckDir' + :: LintConfig' + -> FilePath + -- ^ the repo's directory + -> [FilePath] + -- ^ paths of maps yet to check + -> Map FilePath MapResult + -- ^ accumulator for map results + -> IO (Map FilePath MapResult) +recursiveCheckDir' config prefix paths acc = do -- lint all maps in paths. The double fmap skips maps which cause IO errors -- (in which case loadAndLintMap returns Nothing); appropriate warnings will @@ -218,27 +228,21 @@ recursiveCheckDir' config prefix paths done acc = do in mapMaybeM lintPath paths - let mapdeps = concatMap - (\(m,lintresult) -> - let ps = mapMaybe - (\case {LocalMap p -> Just p; _ -> Nothing}) - (mapresultDepends lintresult) - in map (FP.normalise . normalise (takeDirectory m)) ps - ) - lints - - -- build a Set containing all newly found dependencies, with paths - -- from the repository's directory, normalised not to start with ./ etc. - let setdeps = setFromList - mapdeps - -- that which is yet to do (O(m+n)) - let unknowns = listFromSet $ M.difference setdeps done - -- that which is done - let knowns = M.union done $ setFromList paths - - -- Monoids! - let acc' = acc <> mempty { dirresultMaps = M.fromList lints } - -- Tail recursion! + let mapdeps = setFromList (concatMap extractDeps lints) + where extractDeps (mappath, lintresult) = + fmap (FP.normalise . normalise (takeDirectory mappath)) + . mapMaybe onlyLocalMaps + $ mapresultDepends lintresult + onlyLocalMaps = \case + LocalMap p -> Just p + _ -> Nothing + + let acc' = acc <> M.fromList lints + + -- newly found maps that still need to be checked + let unknowns = listFromSet $ M.difference mapdeps acc + + -- no further maps? return acc'. Otherwise, recurse case unknowns of [] -> pure acc' - _ -> recursiveCheckDir' config prefix unknowns knowns acc' + _ -> recursiveCheckDir' config prefix unknowns acc' diff --git a/lib/Dirgraph.hs b/lib/Dirgraph.hs new file mode 100644 index 0000000..0931ea0 --- /dev/null +++ b/lib/Dirgraph.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Simple directed graphs, for dependency checking +module Dirgraph where + + +import CheckMap (MapResult (mapresultDepends)) +import Data.Map.Strict (Map, mapMaybeWithKey, mapWithKey) +import qualified Data.Map.Strict as M +import Data.Set (Set, (\\)) +import qualified Data.Set as S +import Paths (normalise) +import Types (Dep (LocalMap)) +import Witherable (mapMaybe) + +-- | a simple directed graph +type Graph a = Map a (Set a) + +nodes :: Graph a -> Set a +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) + _ -> Nothing + +-- | invert edges of a directed graph +invertGraph :: (Eq a, Ord a) => Graph a -> Graph a +invertGraph graph = mapWithKey collectFroms graph + where collectFroms to _ = S.fromList . M.elems . mapMaybeWithKey (select to) $ graph + select to from elems = if to `elem` elems then Just from else Nothing + +-- | all nodes reachable from some entrypoint +reachableFrom :: Ord a => a -> Graph a -> Set a +reachableFrom entrypoint graph = recursive mempty (S.singleton entrypoint) + where recursive seen current + | null current = seen + | otherwise = recursive (S.union seen current) (next \\ seen) + where next = S.unions + . S.fromList -- for some reason set is not filterable? + . mapMaybe (`M.lookup` graph) + . S.toList + $ current + +unreachableFrom :: Ord a => a -> Graph a -> Set a +unreachableFrom entrypoint graph = + nodes graph \\ reachableFrom entrypoint graph |