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