From 34c1949525e711beaeb6465a54338ec3bd811712 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 28 Oct 2021 23:15:55 +0200 Subject: flipping the output map structure for now, just with layers. Instead of listing by layer (and giving lints multiple times), list by lint type (and list all layers in which this lint was applicable). This is a bit wonky for now, but readability of output is much better. --- lib/CheckMap.hs | 41 ++++++++++++++++++++++++++++------------- lib/LintWriter.hs | 9 ++++++++- lib/Tiled2.hs | 9 ++++++--- lib/Types.hs | 9 +++++++-- 4 files changed, 49 insertions(+), 19 deletions(-) (limited to 'lib') 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 diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index cdec972..d71d037 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -8,6 +8,7 @@ {-# LANGUAGE RankNTypes #-} -- | a monad that collects warnings, outputs, etc, +{-# LANGUAGE TupleSections #-} module LintWriter where import Control.Monad.Trans.Maybe () @@ -18,8 +19,10 @@ import Data.Text (Text) import Control.Monad.Trans.Reader (Reader, asks, runReader) import Control.Monad.Writer.Lazy (lift) +import Data.Map (Map, fromListWith) import Data.Maybe (mapMaybe) import qualified Data.Text as T +import Tiled2 (HasName (getName)) import Types import Util (PrettyPrint (..)) @@ -28,7 +31,7 @@ import Util (PrettyPrint (..)) -- we currently are type Context = Int --- | a monad to collect hints, with some context +-- | a monad to collect hints, with some context (usually the containing layer/etc.) type LintWriter ctxt = LintWriter' ctxt () type LintWriter' ctxt res = WriterT [Lint] (Reader (Context, ctxt)) res @@ -37,6 +40,10 @@ type LintResult' ctxt = (ctxt, [Lint]) -- Either Lint (a, [Lint]) newtype LintResult ctxt = LintResult (LintResult' ctxt) +invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt] +invertLintResult (LintResult (ctxt, lints)) = + fromListWith (<>) $ fmap (, [ctxt]) $ lintsToHints lints + -- better, less confusing serialisation of an Either Hint (a, [Hint]). -- Note that Left hint is also serialised as a list to make the resulting -- json schema more regular. diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 45b8ad0..3c881ec 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module provides Haskell types for Tiled's JSON exports, which you can -- read about at http://doc.mapeditor.org/en/latest/reference/json-map-format/. @@ -325,7 +325,10 @@ instance HasProperties Layer where instance HasProperties Tileset where getProperties = fromMaybe [] . tilesetProperties - +class HasName a where + getName :: a -> Text +instance HasName Layer where + getName = layerName data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String diff --git a/lib/Types.hs b/lib/Types.hs index c39297f..ab9f8a2 100644 --- a/lib/Types.hs +++ b/lib/Types.hs @@ -10,11 +10,12 @@ module Types where import Control.Monad.Trans.Maybe () -import Data.Aeson (ToJSON (toJSON), (.=)) +import Data.Aeson (ToJSON (toJSON), ToJSONKey, (.=)) import Data.Text (Text) import GHC.Generics (Generic) import qualified Data.Aeson as A +import Data.Maybe (mapMaybe) import Paths (RelPath) import Util (PrettyPrint (..), showText) import WithCli (Argument, Proxy (..), @@ -46,6 +47,7 @@ instance HasArguments Level where -- | a hint comes with an explanation (and a level), or is a dependency -- (in which case it'll be otherwise treated as an info hint) data Lint = Depends Dep | Offers Text | Lint Hint + deriving (Ord, Eq, Generic, ToJSONKey) -- | TODO: add a reasonable representation of possible urls data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath @@ -54,7 +56,7 @@ data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath data Hint = Hint { hintLevel :: Level , hintMsg :: Text - } deriving (Generic) + } deriving (Generic, Ord, Eq) -- | shorter constructor (called hint because (a) older name and -- (b) lint also exists and is monadic) @@ -66,6 +68,9 @@ lintLevel :: Lint -> Level lintLevel (Lint h) = hintLevel h lintLevel _ = Info +lintsToHints :: [Lint] -> [Hint] +lintsToHints = mapMaybe (\case {Lint hint -> Just hint ; _ -> Nothing}) + instance PrettyPrint Lint where prettyprint (Lint Hint { hintMsg, hintLevel } ) = " " <> showText hintLevel <> ": " <> hintMsg -- cgit v1.2.3