summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 14:56:52 +0000