summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2021-12-18 17:19:48 +0100
committerstuebinm2021-12-18 17:19:48 +0100
commit8082e9ef10a08c362adba26aff4f2e5140f6f7f0 (patch)
treeb1edd880406a07d3da0a94f6c1783df1abe9a03d /lib
parent766f883e88afbe476eac0433fc8c731756f64039 (diff)
badges are set on objects, not layers
(and `url` is, too)
Diffstat (limited to 'lib')
-rw-r--r--lib/Properties.hs85
-rw-r--r--lib/TiledAbstract.hs6
2 files changed, 49 insertions, 42 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 0593658..db1ca41 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -68,7 +68,7 @@ checkMap = do
$ complain "The map must have one layer named \"start\"."
unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup")
$ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"."
- unlessLayer (flip containsProperty "exitUrl" . getProperties)
+ unlessLayer (`containsProperty` "exitUrl")
$ complain "The map must contain at least one layer with the property \"exitUrl\" set."
-- reject maps not suitable for workadventure
@@ -195,31 +195,26 @@ checkLayer = do
"group" -> pure ()
"objectgroup" -> do
- -- all objects which can't define badges, i.e. only texts
+ -- all objects which don't define badges
publicObjects <- askContext <&>
- fmap (V.filter (\case {ObjectText {} -> True; _ -> False})) . layerObjects
+ fmap (V.filter (`containsProperty` "getBadge")) . layerObjects
- -- filter everything out that might define badges, but keep text
- -- objects, which workadventure apparently supports but doesn't
- -- really tell anyone about.
+ -- remove badges from output
adjust $ \l -> l { layerObjects = publicObjects
, layerProperties = Nothing }
- unless (layerName layer == "floorLayer") $
- unlessHasProperty "getBadge" $
- when (null publicObjects || publicObjects == Just mempty) $
- warn "objectgroup layer (which aren't the floor layer) \
- \are useless if they do not contain the \"getBadge\" \
- \property and define at least one area for this badge, \
- \or do not contain at least one text element."
-
- -- individual objects can't have properties
- forM_ (fromMaybe mempty (layerObjects layer)) $ \object ->
- unless (null (objectProperties object))
- $ warn "Properties cannot be set on individual objects. For \
- \setting badge tokens, use per-layer properties instead."
+ -- check object properties
+ forM_ (fromMaybe mempty (layerObjects layer)) $ \object -> do
+ mapM_ (checkObjectProperty object) (getProperties object)
+ -- check layer properties
forM_ (getProperties layer) checkObjectGroupProperty
+
+ unless (layerName layer == "floorLayer") $
+ when (null publicObjects || publicObjects == Just mempty) $
+ warn "objectgroup layer (which aren't the floorLayer) \
+ \are useless if they are empty."
+
ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."
if layerType layer == "group"
@@ -228,27 +223,34 @@ checkLayer = do
else when (isJust (layerLayers layer))
$ complain "Layer is not of type \"group\", but has sublayers."
+checkObjectProperty :: Object -> Property -> LintWriter Layer
+checkObjectProperty obj p@(Property name _) = case name of
+ "url" -> pure ()
+ "allowApi" -> forbidProperty name
+ "getBadge" -> do
+ when (1 /= length (getProperties obj))
+ $ warn "Objects with the property \"getBadge\" set are removed at runtime, \
+ \and any other properties set on them will be gone."
+ unwrapString p $ \str ->
+ unwrapBadgeToken str $ \token -> do
+ case obj of
+ ObjectPoint {..} ->
+ offersBadge (Badge token (BadgePoint objectX objectY))
+ ObjectRectangle {..} ->
+ if isJust objectEllipse
+ then offersBadge
+ $ Badge token (BadgeRect objectX objectY objectWidth objectHeight)
+ else complain "ellipses are not supported."
+ ObjectPolygon {} -> complain "polygons are not supported."
+ ObjectPolyline {} -> complain "polylines are not supported."
+ ObjectText {} -> complain "cannot use texts to define badge areas."
+ _ -> warn $ "unknown object property " <> prettyprint name <> "."
+
-- | Checks a single (custom) property of an objectgroup layer
checkObjectGroupProperty :: Property -> LintWriter Layer
-checkObjectGroupProperty p@(Property name _) = case name of
- "getBadge" ->
- unwrapString p $ \str ->
- unwrapBadgeToken str $ \token -> do
- layer <- askContext
- forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> do
- case object of
- ObjectPoint {..} ->
- offersBadge (Badge token (BadgePoint objectX objectY))
- ObjectRectangle {..} ->
- if isJust objectEllipse
- then offersBadge
- $ Badge token (BadgeRect objectX objectY objectWidth objectHeight)
- else complain "ellipses are not supported."
- ObjectPolygon {} -> complain "polygons are not supported."
- ObjectPolyline {} -> complain "polylines are not supported."
- ObjectText {} -> complain "cannot use texts to define badge areas."
- _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
+checkObjectGroupProperty (Property name _) =
+ warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
-- | Checks a single (custom) property of a "normal" tile layer
@@ -341,7 +343,8 @@ checkTileLayerProperty p@(Property name _value) = case name of
"openTab" -> do
isString p
requireProperty "openWebsite"
- "url" -> isForbidden
+ "url" -> complain "the property \"url\" defining embedded iframes must be \
+ \set on an object in an objectgroup layer."
"allowApi" -> isForbidden
"exitUrl" -> do
forbidEmptyLayer
@@ -455,9 +458,9 @@ unlessHasProperty name linter =
unlessElementNamed (getProperties ctxt) name linter
-- | does this layer have the given property?
-containsProperty :: Foldable t => t Property -> Text -> Bool
-containsProperty props name = any
- (\(Property name' _) -> name' == name) props
+containsProperty :: HasProperties a => a -> Text -> Bool
+containsProperty thing name = any
+ (\(Property name' _) -> name' == name) (getProperties thing)
-- | should the layers fulfilling the given predicate collide, then perform andthen.
whenLayerCollisions
diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs
index 88dd2ee..948a91a 100644
--- a/lib/TiledAbstract.hs
+++ b/lib/TiledAbstract.hs
@@ -7,7 +7,7 @@ import Data.Proxy (Proxy)
import Data.Text (Text)
import qualified Data.Vector as V
import Tiled (Layer (..), Property (..), PropertyValue (..),
- Tile (..), Tiledmap (..), Tileset (..))
+ Tile (..), Tiledmap (..), Tileset (..), Object(..))
class HasProperties a where
getProperties :: a -> [Property]
@@ -28,6 +28,10 @@ instance HasProperties Tile where
adjustProperties f tile = tile
{ tileProperties = (fmap V.fromList . f) (getProperties tile) }
+instance HasProperties Object where
+ getProperties = V.toList . fromMaybe mempty . objectProperties
+ adjustProperties f obj = obj
+ { objectProperties = (fmap V.fromList . f) (getProperties obj) }
instance HasProperties Tiledmap where
getProperties = fromMaybe mempty . tiledmapProperties