From 5b8ed8ad906e92bce5b8576b29ae6f2cc46d8696 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 20 Sep 2021 01:56:15 +0200
Subject: lint map things that aren't custom properties

---
 lib/Properties.hs | 35 +++++++++++++++++++++++++++++++----
 1 file changed, 31 insertions(+), 4 deletions(-)

(limited to 'lib/Properties.hs')

diff --git a/lib/Properties.hs b/lib/Properties.hs
index 0805a4d..4dada7d 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -3,13 +3,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Contains checks for custom properties of the map json
-module Properties (checkLayerProperty, checkMapProperty) where
+module Properties (checkLayerProperty, checkMap) where
 
 
 import           Control.Monad (unless, when)
 import           Data.Text     (Text, isPrefixOf)
-import           Tiled2        (Layer (layerProperties), Property (..),
-                                PropertyValue (..), Tiledmap)
+import           Tiled2        (Layer (..), Property (..), PropertyValue (..),
+                                Tiledmap (..))
 import           Util          (layerIsEmpty, prettyprint)
 
 import           LintWriter    (LintWriter, complain, dependsOn, forbid, info,
@@ -122,7 +122,34 @@ checkMapProperty map (Property name value) = case name of
     -- | this property is forbidden and should not be used
     isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
 
-
+-- | 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 :: Tiledmap -> LintWriter ()
+checkMap tiledmap = do
+  -- check properties
+  mapM_ (checkMapProperty tiledmap) (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" . layerProperties)
+    "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
+    layers = tiledmapLayers tiledmap
+    hasLayerNamed name pred = hasLayer (\l -> layerName l == name && pred l)
+    hasLayer pred err =
+      unless (any pred layers)
+        $ complain err
 
 
 
-- 
cgit v1.2.3