diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/CheckMap.hs | 41 | ||||
| -rw-r--r-- | lib/LintWriter.hs | 9 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 9 | ||||
| -rw-r--r-- | lib/Types.hs | 9 |
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 |