diff options
Diffstat (limited to 'lib/CheckDir.hs')
| -rw-r--r-- | lib/CheckDir.hs | 102 |
1 files changed, 59 insertions, 43 deletions
diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 1aeb5e3..a19a412 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -1,29 +1,35 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} +{-# 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) where - -import CheckMap (MapResult (..), loadAndLintMap) -import Control.DeepSeq (NFData) -import Control.Monad (void) +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.Bifunctor (first) -import Data.Foldable (fold) -import Data.Functor ((<&>)) -import Data.List (partition) -import Data.Map (Map, elems, keys) import qualified Data.Map as M import Data.Map.Strict (mapKeys, mapWithKey, (\\)) -import Data.Maybe (isJust, mapMaybe) -import Data.Text (Text, isInfixOf) +import Data.Text (isInfixOf) import qualified Data.Text as T import Dirgraph (graphToDot, invertGraph, resultToGraph, takeSubGraph, unreachableFrom) @@ -34,7 +40,8 @@ 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 Text.Dot (showDot) +import Tiled (Tiledmap) import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint), ellipsis) @@ -49,15 +56,18 @@ listFromSet :: Set a -> [a] listFromSet = map fst . M.toList -- | Result of linting an entire directory / repository -data DirResult = DirResult - { dirresultMaps :: Map FilePath MapResult +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, NFData) + } deriving (Generic) + +instance NFData (Optional a (Maybe Tiledmap)) => NFData (DirResult a) + data MissingDep = MissingDep { depFatal :: Maybe Bool @@ -71,8 +81,14 @@ data MissingDep = MissingDep 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 -> Bool +resultIsFatal :: LintConfig' -> DirResult Full -> Bool resultIsFatal config res = not (null (dirresultMissingAssets res) || not (any (isJust . depFatal) (dirresultDeps res))) || maximumLintLevel res > configMaxLintLevel config @@ -80,11 +96,11 @@ resultIsFatal config res = -- | 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 -> Level +maximumLintLevel :: DirResult a -> Level maximumLintLevel res | not (null (dirresultMissingAssets res)) = Fatal | otherwise = - (\t -> if null t then Info else maximum t) + (maybe Info maximum . nonEmpty) . map hintLevel . concatMap (\map -> keys (mapresultLayer map) <> keys (mapresultTileset map) @@ -96,7 +112,7 @@ maximumLintLevel res -instance ToJSON DirResult where +instance ToJSON (DirResult a) where toJSON res = A.object [ "result" .= A.object [ "missingDeps" .= dirresultDeps res @@ -127,7 +143,7 @@ instance ToJSON MissingAsset where ] -instance PrettyPrint (Level, DirResult) where +instance PrettyPrint (Level, DirResult a) where prettyprint (level, res) = prettyMapLints <> prettyMissingDeps where prettyMissingDeps = if not (null (dirresultDeps res)) @@ -135,9 +151,9 @@ instance PrettyPrint (Level, DirResult) where else "" prettyMapLints = T.concat (map prettyLint $ M.toList $ dirresultMaps res) - prettyLint :: (FilePath, MapResult) -> Text + prettyLint :: (FilePath, MapResult a) -> Text prettyLint (p, lint) = - "\nin " <> T.pack p <> ":\n" <> prettyprint (level, lint) + "\nin " <> toText p <> ":\n" <> prettyprint (level, lint) instance PrettyPrint MissingDep where prettyprint (MissingDep _ f n) = @@ -145,7 +161,7 @@ instance PrettyPrint MissingDep where <> prettyDependents <> "\n" where prettyDependents = - T.intercalate "," $ map T.pack n + T.intercalate "," $ map toText n -- | check an entire repository @@ -155,7 +171,7 @@ recursiveCheckDir -- ^ 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 + -> IO (DirResult Full) recursiveCheckDir config prefix root = do maps <- recursiveCheckDir' config prefix [root] mempty @@ -170,7 +186,7 @@ recursiveCheckDir config prefix root = do 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.") + Hint Warning ("Cannot go back to " <> toText root <> " from this map.") : mapresultGeneral res } else res @@ -180,7 +196,7 @@ recursiveCheckDir config prefix root = do , dirresultMissingAssets = mAssets , dirresultMaps = maps' , dirresultGraph = - T.pack + toText . showDot . graphToDot . takeSubGraph 7 root @@ -190,9 +206,9 @@ recursiveCheckDir config prefix root = do -- | Given a (partially) completed DirResult, check which local -- maps are referenced but do not actually exist. -missingDeps :: FilePath -> Map FilePath MapResult -> [MissingDep] +missingDeps :: FilePath -> Map FilePath (MapResult a) -> [MissingDep] missingDeps entrypoint maps = - let simple = M.insert (T.pack entrypoint) [] used \\ M.union defined trivial + 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? @@ -202,19 +218,19 @@ missingDeps entrypoint maps = (\path v -> map (, [path]) . mapMaybe (extractLocalDeps path) . mapresultDepends $ v) maps where extractLocalDeps prefix = \case - LocalMap name -> Just $ T.pack $ normaliseWithFrag prefix name + LocalMap name -> Just $ toText $ normaliseWithFrag prefix name _ -> Nothing -- which are defined using startLayer? defined :: Set Text defined = setFromList $ M.foldMapWithKey - (\k v -> map ((T.pack k <> "#") <>) . mapresultProvides $ v) + (\k v -> map ((toText k <> "#") <>) . mapresultProvides $ v) maps -- each map file is an entrypoint by itself - trivial = mapKeys T.pack $ void maps + trivial = mapKeys toText $ void maps -- | Checks if all assets referenced in the result actually exist as files -missingAssets :: FilePath -> Map FilePath MapResult -> IO [MissingAsset] +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 @@ -222,7 +238,7 @@ missingAssets prefix maps = let asset = normalise (takeDirectory path) relpath in doesFileExist (prefix </> asset) <&> \case True -> Nothing - False -> Just $ MissingDep Nothing (T.pack asset) [path] + False -> Just $ MissingDep Nothing (toText asset) [path] _ -> pure Nothing) (mapresultDepends mapres) @@ -234,9 +250,9 @@ recursiveCheckDir' -- ^ the repo's directory -> [FilePath] -- ^ paths of maps yet to check - -> Map FilePath MapResult + -> Map FilePath (MapResult Full) -- ^ accumulator for map results - -> IO (Map FilePath MapResult) + -> 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 |