lint map things that aren't custom properties

2 files changed, 36 insertions, 12 deletions

diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 08932b4..ffd94ec 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -17,12 +17,10 @@ import qualified Data.Vector                as V
 import           GHC.Generics               (Generic)
 
 import           LintWriter                 (LintResult (..), LintWriter,
-                                             lintsToDeps, resultToLints,
-                                             runLintWriter)
-import           Properties                 (checkLayerProperty,
-                                             checkMapProperty)
+                                             lintsToDeps, runLintWriter)
+import           Properties                 (checkLayerProperty, checkMap)
 import           Tiled2                     (Layer (layerName, layerProperties),
-                                             Tiledmap (tiledmapLayers, tiledmapProperties),
+                                             Tiledmap (tiledmapLayers),
                                              loadTiledmap)
 import           Types                      (Dep, Level (..), Lint (..), hint,
                                              lintLevel)
@@ -57,7 +55,7 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case
 runLinter :: Tiledmap -> MapResult ()
 runLinter tiledmap = MapResult
   { mapresultLayer = Just layerMap
-  , mapresultGeneral = propertyLints  -- no general lints for now
+  , mapresultGeneral = generalLints  -- no general lints for now
   , mapresultDepends = concatMap (lintsToDeps . snd) layer
   }
   where
@@ -67,8 +65,7 @@ runLinter tiledmap = MapResult
       where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
 
     -- lints collected from properties
-    propertyLints = runLintWriter
-      $ mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap)
+    generalLints = runLintWriter (checkMap tiledmap)
 
 
 -- | collect lints on a single map layer
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