diff options
Diffstat (limited to 'lib/Properties.hs')
| -rw-r--r-- | lib/Properties.hs | 101 |
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.") |