summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/CheckDir.hs20
-rw-r--r--lib/CheckMap.hs18
-rw-r--r--lib/Properties.hs12
-rw-r--r--lib/TiledAbstract.hs8
-rw-r--r--lib/Uris.hs6
-rw-r--r--lib/Util.hs7
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-03 22:18:49 +0000