tiles can also have properties like tile layers

1 files changed, 54 insertions, 47 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
index 2b4203f..a2a84d6 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -19,8 +19,9 @@ import           Tiled             (Layer (..), Object (..), Property (..),
                                     PropertyValue (..), Tile (..),
                                     Tiledmap (..), Tileset (..))
 import           TiledAbstract     (HasName (..), HasProperties (..),
-                                    HasTypeName (..), IsProperty (..))
-import           Util              (layerIsEmpty, mkProxy, naiveEscapeHTML,
+                                    HasTypeName (..), IsProperty (..),
+                                    HasData (..), layerIsEmpty)
+import           Util              (mkProxy, naiveEscapeHTML,
                                     prettyprint, showText)
 
 import           Badges            (Badge (Badge),
@@ -183,19 +184,23 @@ checkTileset = do
   when (isJust (tilesetFileName tileset))
     $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)."
 
+  tiles' <- forM (tilesetTiles tileset) $ mapM $ \tile -> do
+    mapM_ (checkTileProperty tile) (getProperties tile)
+    zoom (const tileset) (const tile) $ mapM_ checkTileThing' (getProperties tile)
+
+  adjust (\t -> t { tilesetTiles = tiles' })
+
   -- check individual tileset properties
   mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset)
 
   case tilesetTiles tileset of
     Nothing -> pure ()
-    Just tiles -> do
+    Just tiles -> refuseDoubledThings tileId
       -- can't set properties on the same tile twice
-      refuseDoubledThings tileId
         (\tile -> complain $ "cannot set properties on the \
                   \tile with the id" <> showText (tileId tile) <> "twice.")
         tiles
 
-      mapM_ checkTile tiles
   where
     checkTilesetProperty :: Property -> LintWriter Tileset
     checkTilesetProperty p@(Property name _value) = case name of
@@ -203,20 +208,21 @@ checkTileset = do
       "collides"         -> warn "property \"collides\" should be set on individual tiles, not the tileset"
       _                  -> warn $ "unknown tileset property " <> prettyprint name
 
-    checkTile :: Tile -> LintWriter Tileset
-    checkTile tile = do
-      refuseDoubledNames (getProperties tile)
-      mapM_ checkTileProperty (getProperties tile)
-      where checkTileProperty :: Property -> LintWriter Tileset
-            checkTileProperty p@(Property name _) = case name of
-              "collides" -> isBool p
-              -- named tiles are needed for scripting and do not hurt otherwise
-              "name" -> isString p
-              "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \
-                                         \not an individual tile."
-              _ -> warnUnknown' ("unknown tile property "
-                      <> prettyprint name <> " in tile with global id "
-                      <> showText (tileId tile)) p knownTilesetProperties
+    checkTileThing' :: Property -> LintWriter Tile
+    checkTileThing' = checkTileThing True
+
+    checkTileProperty :: Tile -> Property -> LintWriter Tileset
+    checkTileProperty tile p@(Property name _) =
+      case name of
+        "collides" -> isBool p
+        -- named tiles are needed for scripting and do not hurt otherwise
+        "name" -> isString p
+        "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \
+                                   \not an individual tile."
+        -- _ -> warnUnknown' ("unknown tile property "
+        --         <> prettyprint name <> " in tile with global id "
+        --         <> showText (tileId tile)) p knownTilesetProperties
+        _ -> pure ()
 
 
 -- | collect lints on a single map layer
@@ -230,7 +236,7 @@ checkLayer = do
     $ complain "imagelayer are not supported."
 
   case layerType layer of
-    "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer)
+    "tilelayer" -> mapM_ (checkTileThing False) (getProperties layer)
     "group" -> pure ()
     "objectgroup" -> do
 
@@ -340,8 +346,8 @@ checkObjectGroupProperty (Property name _) = case name of
 
 
 -- | Checks a single (custom) property of a "normal" tile layer
-checkTileLayerProperty :: Property -> LintWriter Layer
-checkTileLayerProperty p@(Property name _value) = case name of
+checkTileThing :: (HasProperties a, HasName a, HasData a) => Bool -> Property -> LintWriter a
+checkTileThing removeExits p@(Property name _value) = case name of
     "jitsiRoom" -> do
       lintConfig configAssemblyTag
         >>= setProperty "jitsiRoomAdminTag"
@@ -417,24 +423,29 @@ checkTileLayerProperty p@(Property name _value) = case name of
       requireProperty "openWebsiteTrigger"
     "url" -> complain "the property \"url\" defining embedded iframes must be \
                       \set on an object in an objectgroup layer."
-    "exitUrl" -> do
-      forbidEmptyLayer
-      unwrapURI (Proxy @"map") p
-        (\link -> do
-            dependsOn (MapLink link)
-            setProperty "exitUrl" link
-        )
-        $ \path ->
-          let ext = getExtension path in
-          if | isOldStyle path ->
-               complain "Old-Style inter-repository links (using {<placeholder>}) \
-                        \cannot be used at rC3 2021; please use world:// instead \
-                        \(see howto.rc3.world)."
-             | ext == "tmx" ->
-                 complain "Cannot use .tmx map format; use Tiled's json export instead."
-             | ext /= "json" ->
-                 complain "All exit links must link to .json files."
-             | otherwise -> dependsOn . LocalMap $ path
+    "exitUrl" -> if removeExits
+      then do
+        forbidEmptyLayer
+        unwrapURI (Proxy @"map") p
+          (\link -> do
+              dependsOn (MapLink link)
+              setProperty "exitUrl" link
+          )
+          $ \path ->
+            let ext = getExtension path in
+            if | isOldStyle path ->
+                 complain "Old-Style inter-repository links (using {<placeholder>}) \
+                          \cannot be used at rC3 2021; please use world:// instead \
+                          \(see howto.rc3.world)."
+               | ext == "tmx" ->
+                   complain "Cannot use .tmx map format; use Tiled's json export instead."
+               | ext /= "json" ->
+                   complain "All exit links must link to .json files."
+               | otherwise -> dependsOn . LocalMap $ path
+      else do
+        removeProperty "exitUrl"
+        warn "exitUrls in Tilesets are not properly supported; if you want to add an \
+             \exit, please use a tile layer instead."
     "exitSceneUrl" ->
       deprecatedUseInstead "exitUrl"
     "exitInstance" ->
@@ -443,15 +454,11 @@ checkTileLayerProperty p@(Property name _value) = case name of
       forbidEmptyLayer
       layer <- askContext
       unwrapBool p $ \case
-        True  -> offersEntrypoint $ layerName layer
+        True  -> offersEntrypoint $ getName layer
         False -> warn "property \"startLayer\" is useless if set to false."
     "silent" -> do
       isBool p
       uselessEmptyLayer
-    -- "collides" ->
-    --   unwrapBool p $ \case
-    --     True  -> pure ()
-    --     False -> warn "property \"collides\" set to 'false' is useless."
     "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \
                            \ layer; it does not work on tile layers."
 
@@ -500,13 +507,13 @@ checkTileLayerProperty p@(Property name _value) = case name of
 
       -- | this property can only be used on a layer that contains
       -- | at least one tile
-      forbidEmptyLayer = do
+      forbidEmptyLayer = when removeExits $ do
         layer <- askContext
         when (layerIsEmpty layer)
           $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.")
 
       -- | this layer is allowed, but also useless on a layer that contains no tiles
-      uselessEmptyLayer = do
+      uselessEmptyLayer = when removeExits $ do
         layer <- askContext
         when (layerIsEmpty layer)
           $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.")