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)

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