diff options
| -rw-r--r-- | lib/Properties.hs | 85 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 6 |
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 |