Skip to content
Snippets Groups Projects
Select Git revision
  • ec9552b1d6ab303d54a8bbb8c93418f32fa29654
  • main default protected
  • 75389691-a67c-422a-91e9-aa58bfb5-main-patch-32205
  • test-pipe
  • extended-scripts
  • structured-badges
  • guix-pipeline
  • cabal-pipeline
8 results

Properties.hs

Blame
  • 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)