diff options
Diffstat (limited to 'lib/Properties.hs')
| -rw-r--r-- | lib/Properties.hs | 48 |
1 files changed, 33 insertions, 15 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index 27076cb..d65c9da 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -13,18 +13,20 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM_, unless, when) import Data.Text (Text, isPrefixOf) import qualified Data.Vector as V -import Tiled2 (HasProperties (adjustProperties, getProperties), - IsProperty (asProperty), Layer (..), - Object (..), Property (..), PropertyValue (..), - Tiledmap (..), Tileset (..)) -import Util (layerIsEmpty, naiveEscapeHTML, prettyprint, - showText) +import Tiled2 (HasName (getName), + HasProperties (adjustProperties, getProperties), + HasTypeName (typeName), IsProperty (asProperty), + Layer (..), Object (..), Property (..), + PropertyValue (..), Tiledmap (..), Tileset (..)) +import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, + prettyprint, showText) import Badges (Badge (Badge), BadgeArea (BadgePoint, BadgeRect), BadgeToken, parseToken) import Data.Data (Proxy (Proxy)) import Data.Maybe (fromMaybe, isJust) +import qualified Data.Set as S import GHC.TypeLits (KnownSymbol) import LintConfig (LintConfig (..)) import LintWriter (LintWriter, adjust, askContext, askFileDepth, @@ -55,6 +57,9 @@ checkMap = do hasLayer (flip containsProperty "exitUrl" . getProperties) "The map must contain at least one layer with the property \"exitUrl\" set." + refuseDoubledNames (tiledmapLayers tiledmap) + refuseDoubledNames (tiledmapTilesets tiledmap) + -- reject maps not suitable for workadventure unless (tiledmapOrientation tiledmap == "orthogonal") $ complain "The map's orientation must be set to \"orthogonal\"." @@ -106,6 +111,8 @@ checkTileset = do -- TODO: can tilesets be non-local dependencies? unwrapPath (tilesetImage tileset) (dependsOn . Local) + refuseDoubledNames (getProperties tileset) + -- reject tilesets unsuitable for workadventure unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32) $ complain "Tilesets must have tile size 32×32." @@ -135,8 +142,10 @@ checkLayer = do when (isJust (layerImage layer)) $ complain "imagelayer are not supported." + refuseDoubledNames (getProperties layer) + case layerType layer of - "tilelayer" -> mapM_ checkLayerProperty (getProperties layer) + "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer) "group" -> pure () "objectgroup" -> do -- TODO: this still retains object group layers, just empties them out. @@ -190,8 +199,8 @@ checkObjectGroupProperty p@(Property name _) = case name of -- -- It gets a reference to its own layer since sometimes the presence -- of one property implies the presence or absense of another. -checkLayerProperty :: Property -> LintWriter Layer -checkLayerProperty p@(Property name _value) = case name of +checkTileLayerProperty :: Property -> LintWriter Layer +checkTileLayerProperty p@(Property name _value) = case name of "jitsiRoom" -> do lintConfig configAssemblyTag >>= setProperty "jitsiRoomAdminTag" @@ -302,7 +311,6 @@ checkLayerProperty p@(Property name _value) = case name of True -> pure () False -> warn "property \"collides\" set to 'false' is useless." "name" -> isUnsupported - -- all properties relating to scripting are handled the same _ -> warn $ "unknown property type " <> prettyprint name where @@ -325,8 +333,21 @@ checkLayerProperty p@(Property name _value) = case name of $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.") - - +-- | refuse doubled names in everything that's somehow a collection of names +refuseDoubledNames + :: (HasName a, HasTypeName a) + => (Foldable t, Functor t) + => t a + -> LintWriter b +refuseDoubledNames things = foldr folding base things mempty + where + -- this accumulates a function that complains about things it's already seen + folding thing cont seen = do + when (name `elem` seen) + $ complain $ "cannot use " <> typeName (mkProxy thing) <> " name \"" <> name <> "\" twice" + cont (S.insert name seen) + where name = getName thing + base _ = pure () --------- Helper functions & stuff --------- @@ -380,9 +401,6 @@ unwrapString (Property name value) f = case value of StrProp str -> f str _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string." -unwrapString' :: Property -> LintWriter a -> LintWriter a -unwrapString' prop f = unwrapString prop (const f) - -- | same as unwrapString, but also forbids http:// as prefix unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapLink (Property name value) f = case value of |