Select Git revision
Properties.hs
stuebinm authored
(mostly to do with the scripting API, but also some old ones which are already deprecated / not even mentioned in the documentation anymore)
Properties.hs 13.63 KiB
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Contains checks for custom ties of the map json
module Properties (checkMap, checkTileset, checkLayer) where
import Control.Monad (unless, when)
import Data.Text (Text, isPrefixOf)
import Tiled2 (HasProperties (adjustProperties, getProperties),
IsProperty (asProperty), Layer (..),
Property (..), PropertyValue (..),
Tiledmap (..), Tileset (..))
import Util (layerIsEmpty, prettyprint, showText)
import Data.Maybe (fromMaybe, isJust)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
offersEntrypoint, suggest, warn)
import Paths (RelPath (..), parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
-- | Checks an entire map for "general" lints.
--
-- Note that it does /not/ call checkMapProperty; this is handled
-- seperately in CheckMap.hs, since these lints go into a different
-- field of the resulting json.
checkMap :: LintWriter Tiledmap
checkMap = do
tiledmap <- askContext
-- test other things
mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap)
-- some layers should exist
hasLayerNamed "start" (const True)
"The map must have one layer named \"start\""
hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType)
"The map must have one layer named \"floorLayer\" of type \"objectgroup\""
hasLayer (flip containsProperty "exitUrl" . getProperties)
"The map must contain at least one layer with the property \"exitUrl\" set"
-- reject maps not suitable for workadventure
unless (tiledmapOrientation tiledmap == "orthogonal")
$ complain "The map's orientation must be set to \"orthogonal\""
unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
$ complain "The map's tile size must be 32 by 32 pixels"
where
hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l)
hasLayer p err = do
tiledmap <- askContext
unless (any p (tiledmapLayers tiledmap))
$ complain err
-- | Checks a single property of a map.
--
-- Doesn't really do all that much, but could in theory be expanded into a
-- longer function same as checkLayerProperty.
checkMapProperty :: Property -> LintWriter Tiledmap
checkMapProperty (Property name _value) = case name of
"script" -> do
-- this is kind of stupid, since if we also inject script this
-- will be overriden anyways, but it also doesn't really hurt I guess
-- TODO: perhaps include an explanation in the lint, or allow
-- exactly that one value?