summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2021-10-28 23:15:55 +0200
committerstuebinm2021-10-30 15:44:25 +0200
commit34c1949525e711beaeb6465a54338ec3bd811712 (patch)
tree2ff70ab49bdbeefcbbc36dfc82af73ab38c8c896
parentd2983b867a106ee0581d8dc1d8f413178cdd4027 (diff)
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.
-rw-r--r--lib/CheckMap.hs41
-rw-r--r--lib/LintWriter.hs9
-rw-r--r--lib/Tiled2.hs9
-rw-r--r--lib/Types.hs9
4 files changed, 49 insertions, 19 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
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