diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/CheckMap.hs | 41 |
1 files changed, 28 insertions, 13 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index d7d45c0..93c8696 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -8,9 +8,10 @@ -- | Module that contains the high-level checking functions module CheckMap (loadAndLintMap, MapResult(..)) where -import Data.Aeson (ToJSON) +import Data.Aeson (ToJSON (toJSON)) import qualified Data.Aeson as A import Data.Map (Map, fromList, toList) +import qualified Data.Map as M import Data.Maybe (mapMaybe) import Data.Text (Text) import qualified Data.Text as T @@ -19,23 +20,27 @@ import GHC.Generics (Generic) import Data.Aeson.Types ((.=)) +import Data.Map.Lazy (foldlWithKey) import LintWriter (LintResult (..), LintWriter, askContext, - filterLintLevel, lintToDep, resultToDeps, - resultToLints, resultToOffers, runLintWriter) + filterLintLevel, invertLintResult, lintToDep, + resultToDeps, resultToLints, resultToOffers, + runLintWriter) import Properties (checkLayerProperty, checkMap, checkTileset) -import Tiled2 (HasProperties (getProperties), +import Tiled2 (HasName (getName), + HasProperties (getProperties), Layer (layerName, layerProperties), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), Tileset (tilesetName), loadTiledmap) -import Types (Dep, Level (..), Lint (..), hint) +import Types (Dep, Hint (hintLevel, hintMsg), Level (..), + Lint (..), hint) import Util (PrettyPrint (prettyprint), prettyprint) -- | What this linter produces: lints for a single map data MapResult = MapResult - { mapresultLayer :: Map Text (LintResult Layer) + { mapresultLayer :: Map Hint [Layer] --Map Text (LintResult Layer) , mapresultTileset :: Map Text (LintResult Tileset) , mapresultGeneral :: [Lint] , mapresultDepends :: [Dep] @@ -44,7 +49,7 @@ data MapResult = MapResult instance ToJSON MapResult where toJSON res = A.object - [ "layer" .= mapresultLayer res + [ "layer" .= CollectedLints (fmap getName <$> mapresultLayer res) --mapresultLayer res , "tileset" .= mapresultTileset res , "general" .= mapresultGeneral res -- TODO: not sure if these are necessary of even useful @@ -52,6 +57,14 @@ instance ToJSON MapResult where , "provides" .= mapresultProvides res ] +newtype CollectedLints = CollectedLints (Map Hint [Text]) + +instance ToJSON CollectedLints where + toJSON (CollectedLints col) = toJSON + . M.mapKeys hintMsg + $ M.mapWithKey (\h cs -> A.object [ "level" .= hintLevel h, "in" .= cs ]) col + + -- | this module's raison d'être -- Lints the map at `path`, and limits local links to at most `depth` -- layers upwards in the file hierarchy @@ -74,17 +87,19 @@ loadAndLintMap path depth = loadTiledmap path >>= pure . \case -- | lint a loaded map runLinter :: Tiledmap -> Int -> MapResult runLinter tiledmap depth = MapResult - { mapresultLayer = fromList layer + { mapresultLayer = layer' , mapresultTileset = fromList tileset , mapresultGeneral = generalLints - , mapresultDepends = concatMap (resultToDeps . snd) layer - <> mapMaybe lintToDep generalLints + , mapresultDepends = --concatMap (resultToDeps . snd) layer + {-<>-} mapMaybe lintToDep generalLints <> concatMap (resultToDeps . snd) tileset - , mapresultProvides = concatMap (resultToOffers . snd) layer + , mapresultProvides = mempty --concatMap (resultToOffers . snd) layer } where + layer' = M.unionsWith (<>) $ fmap invertLintResult layer + layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap - where runCheck l = (layerName l, runLintWriter l depth checkLayer) + where runCheck l = runLintWriter l depth checkLayer tileset = V.toList . V.map runCheck $ tiledmapTilesets tiledmap where runCheck l = (tilesetName l, runLintWriter l depth (checkTileset l)) @@ -109,7 +124,7 @@ instance PrettyPrint (Level, MapResult) where -- TODO: this can be simplified further prettyLayer :: [Text] prettyLayer = mapMaybe - (\(_,l) -> Just $ prettyprint (level, l)) + (\(_,l) -> Just $ {-prettyprint level <> -}(T.concat $ fmap prettyprint $ fmap getName l)) (toList . mapresultLayer $ mapResult) prettyTileset :: [Text] prettyTileset = mapMaybe |