Select Git revision
Properties.hs
Properties.hs 15.31 KiB
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
-- | Contains checks for custom ties of the map json
{-# LANGUAGE DataKinds #-}
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.Data (Proxy (Proxy))
import Data.Maybe (fromMaybe, isJust)
import GHC.TypeLits (KnownSymbol)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
offersEntrypoint, suggest, warn)
import Paths (PathResult (..), RelPath (..), parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
import Uris (SubstError (..), applySubst)
import Data.Functor ((<&>))
-- | 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