diff options
Diffstat (limited to 'walint/CheckDir.hs')
| -rw-r--r-- | walint/CheckDir.hs | 279 |
1 files changed, 279 insertions, 0 deletions
diff --git a/walint/CheckDir.hs b/walint/CheckDir.hs new file mode 100644 index 0000000..c82c54b --- /dev/null +++ b/walint/CheckDir.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# 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' |