From a74cc87b085fa15213f8901f091db2631fee10db Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 17 Oct 2021 21:27:50 +0200 Subject: add tileset property linting this reorganised the whole linting for tilesets somewhat; it's now very similar to that linting layers, and it may be possible to abstract some of the code away ... --- lib/CheckMap.hs | 25 ++++++++++++++++++------- lib/Properties.hs | 29 +++++++++++++++++++++++------ lib/Tiled2.hs | 2 +- lib/Util.hs | 7 +++++-- 4 files changed, 47 insertions(+), 16 deletions(-) (limited to 'lib') diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 8b4dca8..036f4e8 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -22,10 +22,11 @@ import Data.Aeson.Types ((.=)) import LintWriter (LintResult (..), LintWriter, askContext, filterLintLevel, lintToDep, resultToDeps, resultToLints, resultToOffers, runLintWriter) -import Properties (checkLayerProperty, checkMap) +import Properties (checkLayerProperty, checkMap, checkTileset) import Tiled2 (Layer (layerName, layerProperties), - LoadResult (..), Tiledmap (tiledmapLayers), - loadTiledmap) + LoadResult (..), + Tiledmap (tiledmapLayers, tiledmapTilesets), + Tileset (tilesetName), loadTiledmap) import Types (Dep, Level (..), Lint (..), hint) import Util (PrettyPrint (prettyprint), prettyprint) @@ -34,6 +35,7 @@ import Util (PrettyPrint (prettyprint), prettyprint) -- | What this linter produces: lints for a single map data MapResult = MapResult { mapresultLayer :: Map Text (LintResult Layer) + , mapresultTileset :: Map Text (LintResult Tileset) , mapresultGeneral :: [Lint] , mapresultDepends :: [Dep] , mapresultProvides :: [Text] @@ -42,6 +44,7 @@ data MapResult = MapResult instance ToJSON MapResult where toJSON res = A.object [ "layer" .= mapresultLayer res + , "tileset" .= mapresultTileset res , "general" .= mapresultGeneral res -- TODO: not sure if these are necessary of even useful , "depends" .= mapresultDepends res @@ -55,6 +58,7 @@ loadAndLintMap :: FilePath -> Int -> IO (Maybe MapResult) loadAndLintMap path depth = loadTiledmap path >>= pure . \case DecodeErr err -> Just $ MapResult { mapresultLayer = mempty + , mapresultTileset = mempty , mapresultDepends = [] , mapresultProvides = [] , mapresultGeneral = @@ -69,17 +73,19 @@ loadAndLintMap path depth = loadTiledmap path >>= pure . \case -- | lint a loaded map runLinter :: Tiledmap -> Int -> MapResult runLinter tiledmap depth = MapResult - { mapresultLayer = layerMap - , mapresultGeneral = generalLints -- no general lints for now + { mapresultLayer = fromList layer + , mapresultTileset = fromList tileset + , mapresultGeneral = generalLints , mapresultDepends = concatMap (resultToDeps . snd) layer <> mapMaybe lintToDep generalLints + <> concatMap (resultToDeps . snd) tileset , mapresultProvides = concatMap (resultToOffers . snd) layer } where - layerMap :: Map Text (LintResult Layer) - layerMap = fromList layer layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap where runCheck l = (layerName l, runLintWriter l depth checkLayer) + tileset = V.toList . V.map runCheck $ tiledmapTilesets tiledmap + where runCheck l = (tilesetName l, runLintWriter l depth (checkTileset l)) -- lints collected from properties generalLints = @@ -98,11 +104,16 @@ instance PrettyPrint (Level, MapResult) where then " all good!\n" else prettyLints where prettyLints = T.concat $ prettyGeneral <> prettyLayer + <> prettyTileset -- TODO: this can be simplified further prettyLayer :: [Text] prettyLayer = mapMaybe (\(_,l) -> Just $ prettyprint (level, l)) (toList . mapresultLayer $ mapResult) + prettyTileset :: [Text] + prettyTileset = mapMaybe + (\(_,t) -> Just $ prettyprint (level, t)) + (toList . mapresultTileset $ mapResult) prettyGeneral :: [Text] prettyGeneral = map ((<> "\n") . prettyprint) diff --git a/lib/Properties.hs b/lib/Properties.hs index 241a076..ee774c8 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | Contains checks for custom properties of the map json -module Properties (checkLayerProperty, checkMap) where +module Properties (checkLayerProperty, checkMap, checkTileset) where import Control.Monad (unless, when) @@ -30,7 +30,6 @@ checkMap = do -- test other things mapM_ checkMapProperty (tiledmapProperties tiledmap) - mapM_ checkTileset (tiledmapTilesets tiledmap) -- some layers should exist hasLayerNamed "start" (const True) @@ -69,7 +68,7 @@ checkMapProperty (Property name _value) = case name of -- | check an embedded tile set. -- -- Important to collect dependency files -checkTileset :: Tileset -> LintWriter Tiledmap +checkTileset :: Tileset -> LintWriter Tileset checkTileset tileset = do -- TODO: can tilesets be non-local dependencies? unwrapPath (tilesetImage tileset) (dependsOn . Local) @@ -81,6 +80,14 @@ checkTileset tileset = do unless (tilesetImageheight tileset < 4096 && tilesetImagewidth tileset < 4096) $ warn $ "Tileset " <> tilesetName tileset <> " should not be larger than 4096×4096 pixels in total" + -- TODO: check copyright! + requireProperty "copyright" + mapM_ checkTilesetProperty (tilesetProperties tileset) + +checkTilesetProperty :: Property -> LintWriter Tileset +checkTilesetProperty p@(Property name value) = case name of + "copyright" -> pure () -- only allow some licenses? + _ -> pure () -- are there any other properties? -- | Checks a single (custom) property of a layer -- @@ -174,10 +181,19 @@ checkLayerProperty p@(Property name _value) = case name of --------- Helper functions & stuff --------- -unlessHasProperty :: Text -> LintWriter Layer -> LintWriter Layer +class HasProperties a where + getProperties :: a -> [Property] + +instance HasProperties Layer where + getProperties = layerProperties + +instance HasProperties Tileset where + getProperties = tilesetProperties + +unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a unlessHasProperty name andthen = do layer <- askContext - let hasprop = any (\(Property name' _) -> name == name') (layerProperties layer) + let hasprop = any (\(Property name' _) -> name == name') (getProperties layer) unless hasprop andthen @@ -187,8 +203,9 @@ forbidProperty name = do forbid $ "property " <> prettyprint name <> " should not be used" + -- | require some property -requireProperty :: Text -> LintWriter Layer +requireProperty :: HasProperties a => Text -> LintWriter a requireProperty name = unlessHasProperty name $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 724be1d..3fc8c31 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -309,7 +309,7 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId -- ^ Width of source image in pixels , tilesetImageheight :: Int -- ^ Height of source image in pixels - , tilesetProperties :: Map Text Text + , tilesetProperties :: [Property] -- ^ String key-value pairs , tilesetPropertytypes :: Map Text Text -- ^ String key-value pairs diff --git a/lib/Util.hs b/lib/Util.hs index 47ee7f2..18dfb5b 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -9,8 +9,8 @@ module Util where import Data.Aeson as Aeson import Data.Text (Text) import qualified Data.Text as T -import Tiled2 (Layer (layerData), PropertyValue (..), layerName, - mkTiledId) +import Tiled2 (Layer (layerData), PropertyValue (..), + Tileset (tilesetName), layerName, mkTiledId) -- | haskell's many string types are FUN … showText :: Show a => a -> Text @@ -43,6 +43,9 @@ instance PrettyPrint () where instance PrettyPrint Layer where prettyprint = (<>) "layer " . layerName +instance PrettyPrint Tileset where + prettyprint = (<>) "tileset " . tilesetName + printPretty :: PrettyPrint a => a -> IO () printPretty = putStr . T.unpack . prettyprint -- cgit v1.2.3