Select Git revision
Properties.hs
Properties.hs 20.30 KiB
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
-- | Contains checks for custom ties of the map json
module Properties (checkMap, checkTileset, checkLayer) where
import Control.Monad (forM_, unless, when)
import Data.Text (Text, isPrefixOf)
import qualified Data.Vector as V
import Tiled (Layer (..), Object (..), Property (..),
PropertyValue (..), Tiledmap (..), Tileset (..))
import TiledAbstract (HasName (..), HasProperties (..),
HasTypeName (..), IsProperty (..))
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 Data.Set (Set)
import qualified Data.Set as S
import GHC.TypeLits (KnownSymbol)
import LayerData (Collision, layerOverlaps)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
offersBadge, offersEntrypoint, suggest, warn)
import Paths (PathResult (..), RelPath (..), parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
import Uris (SubstError (..), applySubst)
-- | Checks an entire map for "general" lints.
--
-- Note that it does /not/ check any tile layer/tileset properties;
-- these are handled seperately in CheckMap, since these lints go
-- into a different field of the output.
checkMap :: LintWriter Tiledmap
checkMap = do
tiledmap <- askContext
let unlessLayer = unlessElement (tiledmapLayers tiledmap)
-- test custom map properties
mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap)
-- can't have these with the rest of layer/tileset lints since they're
-- not specific to any one of them
refuseDoubledNames (tiledmapLayers tiledmap)
refuseDoubledNames (tiledmapTilesets tiledmap)
-- some layers should exist
unlessElementNamed (tiledmapLayers tiledmap) "start"
$ 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)
$ complain "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)