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 ...

4 files changed, 47 insertions, 16 deletions

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