Skip to content
Snippets Groups Projects
Select Git revision
  • 46b4591532f9ecf16bf382fded5fa5fd413527ac
  • 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 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