diff options
Diffstat (limited to 'lib/CheckDir.hs')
| -rw-r--r-- | lib/CheckDir.hs | 284 |
1 files changed, 0 insertions, 284 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs deleted file mode 100644 index 104fdae..0000000 --- a/lib/CheckDir.hs +++ /dev/null @@ -1,284 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Module that contains high-level checking for an entire directory -module CheckDir ( maximumLintLevel - , recursiveCheckDir - , DirResult (..) - , MissingAsset(..) - , MissingDep(..) - , resultIsFatal - ,shrinkDirResult) where - -import Universum hiding (Set) - -import CheckMap (MapResult (..), Optional, - ResultKind (..), loadAndLintMap, - shrinkMapResult) -import Control.Monad.Extra (mapMaybeM) -import Data.Aeson (ToJSON, (.=)) -import qualified Data.Aeson as A -import Data.List (partition) -import qualified Data.Map as M -import Data.Map.Strict (mapKeys, mapWithKey, (\\)) -import Data.Text (isInfixOf) -import qualified Data.Text as T -import Data.Tiled (Tiledmap) -import Dirgraph (graphToDot, invertGraph, resultToGraph, - takeSubGraph, unreachableFrom) -import LintConfig (LintConfig', configMaxLintLevel) -import Paths (normalise, normaliseWithFrag) -import System.Directory.Extra (doesFileExist) -import qualified System.FilePath as FP -import System.FilePath (splitPath, (</>)) -import System.FilePath.Posix (takeDirectory) -import Text.Dot (showDot) -import Types (Dep (Local, LocalMap), Hint (Hint), - Level (..), hintLevel) -import Util (PrettyPrint (prettyprint), ellipsis) - - --- based on the startling observation that Data.Map has lower complexity --- for difference than Data.Set, but the same complexity for fromList -type Set a = Map a () -setFromList :: Ord a => [a] -> Set a -setFromList = M.fromList . flip zip (repeat ()) -listFromSet :: Set a -> [a] -listFromSet = map fst . M.toList - --- | Result of linting an entire directory / repository -data DirResult (complete :: ResultKind) = DirResult - { dirresultMaps :: Map FilePath (MapResult complete) - -- ^ all maps of this respository, by (local) filepath - , dirresultDeps :: [MissingDep] - -- ^ all dependencies to things outside this repository - , dirresultMissingAssets :: [MissingAsset] - -- ^ entrypoints of maps which are referred to but missing - , dirresultGraph :: Text - } deriving (Generic) - -instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) - - -data MissingDep = MissingDep - { depFatal :: Maybe Bool - , entrypoint :: Text - , neededBy :: [FilePath] - } deriving (Generic, ToJSON, NFData) - --- | Missing assets are the same thing as missing dependencies, --- but should not be confused (and also serialise differently --- to json) -newtype MissingAsset = MissingAsset MissingDep - deriving (Generic, NFData) - - --- | "shrink" the result by throwing the adjusted tiledmaps away -shrinkDirResult :: DirResult Full -> DirResult Shrunk -shrinkDirResult !res = - res { dirresultMaps = fmap shrinkMapResult (dirresultMaps res) } - --- | given this config, should the result be considered to have failed? -resultIsFatal :: LintConfig' -> DirResult Full -> Bool -resultIsFatal config res = - not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) - || maximumLintLevel res > configMaxLintLevel config - --- | maximum lint level that was observed anywhere in any map. --- note that it really does go through all lints, so don't --- call it too often -maximumLintLevel :: DirResult a -> Level -maximumLintLevel res - | not (null (dirresultMissingAssets res)) = Fatal - | otherwise = - (maybe Info maximum . nonEmpty) - . map hintLevel - . concatMap (\map -> keys (mapresultLayer map) - <> keys (mapresultTileset map) - <> mapresultGeneral map - ) - . elems - . dirresultMaps - $ res - - - -instance ToJSON (DirResult a) where - toJSON res = A.object [ - "result" .= A.object - [ "missingDeps" .= dirresultDeps res - , "missingAssets" .= dirresultMissingAssets res - -- some repos have auto-generated maps which are basically all the - -- same; aggregate those to reduce output size - , "mapLints" .= (M.fromList - . fmap (first (ellipsis 6)) - . foldr aggregateSameResults [] - . M.toList - $ dirresultMaps res) - , "exitGraph" .= dirresultGraph res - ] - , "severity" .= maximumLintLevel res - , "mapInfo" .= fmap (\tm -> A.object [ "badges" .= mapresultBadges tm ]) - (dirresultMaps res) - ] - where - aggregateSameResults (path,res) acc = - case partition (\(_,res') -> res == res') acc of - ([],_) -> ([toText path], res):acc - ((paths,_):_,acc') -> (toText path:paths, res) : acc' - -instance ToJSON MissingAsset where - toJSON (MissingAsset md) = A.object - [ "asset" .= entrypoint md - , "neededBy" .= neededBy md - ] - - -instance PrettyPrint (Level, DirResult a) where - prettyprint (level, res) = prettyMapLints <> prettyMissingDeps - where - prettyMissingDeps = if not (null (dirresultDeps res)) - then "\nDependency Errors:\n" <> foldMap prettyprint (dirresultDeps res) - else "" - prettyMapLints = T.concat - (map prettyLint $ M.toList $ dirresultMaps res) - prettyLint :: (FilePath, MapResult a) -> Text - prettyLint (p, lint) = - "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) - -instance PrettyPrint MissingDep where - prettyprint (MissingDep _ f n) = - " - " <> f <> " does not exist, but is required by " - <> prettyDependents <> "\n" - where - prettyDependents = - T.intercalate "," $ map toText n - - --- | 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 Full) -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 - $ exitGraph - - -- 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 " <> toText root <> " from this map.") - : mapresultGeneral res - } - else res - - mAssets <- missingAssets prefix maps' - pure $ DirResult { dirresultDeps = missingDeps root maps' - , dirresultMissingAssets = mAssets - , dirresultMaps = maps' - , dirresultGraph = - toText - . showDot - . graphToDot - . takeSubGraph 7 root - $ exitGraph - } - - --- | Given a (partially) completed DirResult, check which local --- maps are referenced but do not actually exist. -missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] -missingDeps entrypoint maps = - let simple = M.insert (toText entrypoint) [] used \\ M.union defined trivial - in M.foldMapWithKey (\f n -> [MissingDep (Just $ not ("#" `isInfixOf` f)) f n]) simple - where - -- which maps are linked somewhere? - used :: Map Text [FilePath] - used = M.fromList - $ M.foldMapWithKey - (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) - maps - where extractLocalDeps prefix = \case - LocalMap name -> Just $ toText $ normaliseWithFrag prefix name - _ -> Nothing - -- which are defined using startLayer? - defined :: Set Text - defined = setFromList - $ M.foldMapWithKey - (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) - maps - -- each map file is an entrypoint by itself - trivial = mapKeys toText $ void maps - --- | Checks if all assets referenced in the result actually exist as files -missingAssets :: FilePath -> Map FilePath (MapResult a) -> 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 - in doesFileExist (prefix </> asset) <&> - \case True -> Nothing - False -> Just $ MissingDep Nothing (toText asset) [path] - _ -> pure Nothing) - (mapresultDepends mapres) - - --- | 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 Full) - -- ^ accumulator for map results - -> IO (Map FilePath (MapResult Full)) -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 - -- show up later during dependency checks - lints <- - let lintPath p = fmap (fmap (p,)) (loadAndLintMap config (prefix </> p) depth) - where depth = length (splitPath p) - 1 - in mapMaybeM lintPath paths >>= evaluateNF - - - 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 acc' |