diff options
Diffstat (limited to 'lib/CheckDir.hs')
| -rw-r--r-- | lib/CheckDir.hs | 138 |
1 files changed, 71 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' |