Properties.hs

{-# 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           Tiled2        (HasProperties (adjustProperties, getProperties),
                                IsProperty (asProperty), Layer (..),
                                Object (..), Property (..), PropertyValue (..),
                                Tiledmap (..), Tileset (..))
import           Util          (layerIsEmpty, naiveEscapeHTML, prettyprint,
                                showText)

import           Badges        (Badge (Badge),
                                BadgeArea (BadgePoint, BadgeRect), BadgeToken,
                                parseToken)
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,
                                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/ 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