From 0419aa9918723c8b74252bf6ff1a2162c2f3a89a Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 29 Dec 2021 04:49:46 +0100 Subject: maps, maps, and yet more maps don't add maps to the result if their lint result looks the same as that of another list, just say it happened several times instead (this leads to a rather confusing Eq instance for MapResult which implements a very simple surface-level equality — perhaps change that later) --- lib/CheckDir.hs | 20 +++++++++++++++++--- lib/CheckMap.hs | 18 ++++++++++++++---- lib/Properties.hs | 12 ++++++------ lib/TiledAbstract.hs | 8 ++++---- lib/Uris.hs | 6 +++--- lib/Util.hs | 7 ++++++- 6 files changed, 50 insertions(+), 21 deletions(-) diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 59c6f2f..cb4f886 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -14,8 +14,10 @@ import Control.Monad (void) 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, (\\)) @@ -34,7 +36,7 @@ import System.FilePath.Posix (takeDirectory) import Text.Dot (Dot, showDot) import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) -import Util (PrettyPrint (prettyprint)) +import Util (PrettyPrint (prettyprint), ellipsis) -- based on the startling observation that Data.Map has lower complexity @@ -97,13 +99,25 @@ instance ToJSON DirResult where "result" .= A.object [ "missingDeps" .= dirresultDeps res , "missingAssets" .= dirresultMissingAssets res - , "mapLints" .= dirresultMaps res - , "exitGraph" .= showDot (dirresultGraph 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) + -- unused in the hub, temporarily removed to make the output smaller + -- , "exitGraph" .= showDot (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 + ([],_) -> ([T.pack path], res):acc + ((paths,_):_,acc') -> (T.pack path:paths, res) : acc' instance ToJSON MissingAsset where toJSON (MissingAsset md) = A.object diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index fead0b9..885ee70 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -21,20 +21,21 @@ import GHC.Generics (Generic) import Badges (Badge) -import LintConfig (LintConfig', LintConfig (configAssemblyTag)) +import LintConfig (LintConfig (configAssemblyTag), LintConfig') import LintWriter (LintResult, invertLintResult, resultToAdjusted, resultToBadges, resultToDeps, resultToLints, resultToOffers, runLintWriter) import Properties (checkLayer, checkMap, checkTileset) +import System.FilePath (takeFileName) import Tiled (Layer (layerLayers, layerName), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), loadTiledmap) -import Types (Dep (MapLink), Hint (Hint, hintLevel, hintMsg), - Level (..), lintsToHints) +import Types (Dep (MapLink), + Hint (Hint, hintLevel, hintMsg), Level (..), + lintsToHints) import Util (PrettyPrint (prettyprint), prettyprint) -import System.FilePath (takeFileName) @@ -56,6 +57,15 @@ data MapResult = MapResult -- ^ general-purpose lints that didn't fit anywhere else } deriving (Generic) + +instance Eq MapResult where + a == b = + mapresultLayer a == mapresultLayer b && + mapresultTileset a == mapresultTileset b && + -- mapresultBadges a == mapresultBadges b && + mapresultGeneral a == mapresultGeneral b + + instance ToJSON MapResult where toJSON res = A.object [ "layer" .= CollectedLints (mapresultLayer res) diff --git a/lib/Properties.hs b/lib/Properties.hs index 605f970..e594751 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -12,17 +12,17 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM, forM_, unless, when) -import Data.Text (Text, intercalate, isPrefixOf, isInfixOf) +import Data.Text (Text, intercalate, isInfixOf, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V import Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), Tiledmap (..), Tileset (..)) -import TiledAbstract (HasName (..), HasProperties (..), - HasTypeName (..), IsProperty (..), - HasData (..), layerIsEmpty) -import Util (mkProxy, naiveEscapeHTML, - prettyprint, showText) +import TiledAbstract (HasData (..), HasName (..), + HasProperties (..), HasTypeName (..), + IsProperty (..), layerIsEmpty) +import Util (mkProxy, naiveEscapeHTML, prettyprint, + showText) import Badges (Badge (Badge), BadgeArea (BadgePoint, BadgeRect), diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs index 0ccf26b..5589207 100644 --- a/lib/TiledAbstract.hs +++ b/lib/TiledAbstract.hs @@ -5,12 +5,12 @@ module TiledAbstract where import Data.Maybe (fromMaybe) import Data.Proxy (Proxy) import Data.Text (Text) +import Data.Vector (Vector) import qualified Data.Vector as V -import Tiled (Layer (..), Object (..), Property (..), +import Tiled (GlobalId, Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), Tiledmap (..), - Tileset (..), mkTiledId, GlobalId) -import Data.Vector (Vector) -import Util (showText) + Tileset (..), mkTiledId) +import Util (showText) class HasProperties a where getProperties :: a -> [Property] diff --git a/lib/Uris.hs b/lib/Uris.hs index 5c2ad05..6436ac6 100644 --- a/lib/Uris.hs +++ b/lib/Uris.hs @@ -22,9 +22,9 @@ import Data.Text (Text, pack) import qualified Data.Text as T import GHC.Generics (Generic) import GHC.TypeLits (KnownSymbol, symbolVal) +import Network.URI.Encode as URI import Text.Regex.TDFA ((=~)) -import Witherable (mapMaybe) -import Network.URI.Encode as URI +import Witherable (mapMaybe) data Substitution = Prefixed { prefix :: Text, blocked :: [Text], allowed :: [Text], scope :: [String] } @@ -82,7 +82,7 @@ applySubsts s substs uri = do [] -> Left (SchemaDoesNotExist schema) results@(_:_) -> case mapMaybe rightToMaybe results of suc:_ -> Right suc - _ -> minimum results + _ -> minimum results where note = maybeToRight diff --git a/lib/Util.hs b/lib/Util.hs index d760fc2..3fe0a16 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -66,7 +66,12 @@ printPretty :: PrettyPrint a => a -> IO () printPretty = putStr . T.unpack . prettyprint - +-- | for long lists which shouldn't be printed out in their entirety +ellipsis :: Int -> [Text] -> Text +ellipsis i texts + | i < l = prettyprint (take i texts) <> " ... (and " <> showText (l-i) <> " more)" + | otherwise = prettyprint texts + where l = length texts -- cgit v1.2.3