summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/Properties.hs101
-rw-r--r--lib/TiledAbstract.hs22
-rw-r--r--lib/Util.hs8
3 files changed, 79 insertions, 52 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.")
diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs
index 6d58f46..0ccf26b 100644
--- a/lib/TiledAbstract.hs
+++ b/lib/TiledAbstract.hs
@@ -8,7 +8,9 @@ import Data.Text (Text)
import qualified Data.Vector as V
import Tiled (Layer (..), Object (..), Property (..),
PropertyValue (..), Tile (..), Tiledmap (..),
- Tileset (..))
+ Tileset (..), mkTiledId, GlobalId)
+import Data.Vector (Vector)
+import Util (showText)
class HasProperties a where
getProperties :: a -> [Property]
@@ -39,6 +41,14 @@ instance HasProperties Tiledmap where
adjustProperties f tiledmap = tiledmap
{ tiledmapProperties = f (getProperties tiledmap) }
+class HasData a where
+ getData :: a -> Maybe (Vector GlobalId)
+instance HasData Layer where
+ getData = layerData
+instance HasData Tile where
+ getData _ = Nothing
+
+
class HasTypeName a where
typeName :: Proxy a -> Text
instance HasTypeName Layer where
@@ -48,6 +58,7 @@ instance HasTypeName Tileset where
instance HasTypeName Property where
typeName _ = "property"
+
class HasName a where
getName :: a -> Text
instance HasName Layer where
@@ -56,6 +67,9 @@ instance HasName Tileset where
getName = tilesetName
instance HasName Property where
getName (Property n _) = n
+instance HasName Tile where
+ getName tile = "[tile with global id " <> showText (tileId tile) <> "]"
+
class IsProperty a where
asProperty :: a -> PropertyValue
@@ -65,3 +79,9 @@ instance IsProperty PropertyValue where
instance IsProperty Text where
asProperty = StrProp
{-# INLINE asProperty #-}
+
+
+layerIsEmpty :: HasData a => a -> Bool
+layerIsEmpty layer = case getData layer of
+ Nothing -> True
+ Just d -> all ((==) $ mkTiledId 0) d
diff --git a/lib/Util.hs b/lib/Util.hs
index a6c8354..d760fc2 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -15,6 +15,7 @@ import qualified Data.Text as T
import Tiled (Layer (layerData), PropertyValue (..),
Tileset (tilesetName), layerName, mkTiledId)
+
-- | helper function to create proxies
mkProxy :: a -> Proxy a
mkProxy = const Proxy
@@ -65,10 +66,9 @@ printPretty :: PrettyPrint a => a -> IO ()
printPretty = putStr . T.unpack . prettyprint
-layerIsEmpty :: Layer -> Bool
-layerIsEmpty layer = case layerData layer of
- Nothing -> True
- Just d -> all ((==) $ mkTiledId 0) d
+
+
+
-- | naive escaping of html sequences, just to be sure that
-- | workadventure won't mess things up again …
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 20:25:30 +0000