1 files changed, 57 insertions, 9 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
index f78ceff..27076cb 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -1,33 +1,38 @@
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# 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           Control.Monad (forM_, unless, when)
 import           Data.Text     (Text, isPrefixOf)
+import qualified Data.Vector   as V
 import           Tiled2        (HasProperties (adjustProperties, getProperties),
                                 IsProperty (asProperty), Layer (..),
-                                Property (..), PropertyValue (..),
+                                Object (..), Property (..), PropertyValue (..),
                                 Tiledmap (..), Tileset (..))
-import           Util          (layerIsEmpty, prettyprint, showText)
+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,
-                                offersEntrypoint, suggest, warn)
+                                offersBadge, 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.
@@ -133,8 +138,25 @@ checkLayer = do
   case layerType layer of
     "tilelayer" -> mapM_ checkLayerProperty (getProperties layer)
     "group" -> pure ()
-    ty -> unless (layerName layer == "floorLayer" && ty == "objectgroup")
-          $ complain "only group and tilelayer are supported."
+    "objectgroup" -> do
+      -- TODO: this still retains object group layers, just empties them out.
+      -- perhaps actually delete the entire layer, since this still leaves hints
+      -- as to where badges are?
+      adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing }
+
+      unless (layerName layer == "floorLayer") $ do
+        unlessHasProperty "getBadge"
+          $ warn "objectgrouop layer (which aren't the floor layer) are useless if not used to define badges."
+        when (null (layerObjects layer) || layerObjects layer == Just (V.fromList []))
+          $ warn "empty objectgroup layers (which aren't the floor layer) are useless."
+
+      -- individual objects can't have properties
+      forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object ->
+        unless (null (objectProperties object))
+          $ warn "Properties cannot be set on individual objects. For setting badge tokens, use per-layer properties instead."
+      mapM_ checkObjectGroupProperty (getProperties layer)
+    ty -> --unless (layerName layer == "floorLayer" && ty == "objectgroup")
+          complain $ "unsupported layer type " <> prettyprint ty <> "."
 
   if layerType layer == "group"
     then when (null (layerLayers layer))
@@ -143,7 +165,28 @@ checkLayer = do
     $ complain "Layer is not of type \"group\", but has sublayers."
 
 
--- | Checks a single (custom) property of a layer
+-- | Checks a single (custom) property of an objectgroup layer
+checkObjectGroupProperty :: Property -> LintWriter Layer
+checkObjectGroupProperty p@(Property name _) = case name of
+  "getBadge" ->  -- TODO check if all objects of this layer are allowed, then collect them
+    unwrapString p $ \str ->
+      unwrapBadgeToken str $ \token -> do
+        layer <- askContext
+        forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object -> do
+          case object of
+            ObjectPoint {..} ->
+              offersBadge (Badge token (BadgePoint objectX objectY))
+            ObjectRectangle {..} ->
+              offersBadge (Badge token area)
+              where area = BadgeRect
+                      objectX objectY
+                      objectWidth objectHeight
+                      (objectEllipse == Just True)
+            ObjectPolygon {} -> complain "cannot use polygons for badges."
+            ObjectPolyline {} -> complain "cannot use polylines for badges."
+  _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
+
+-- | Checks a single (custom) property of a "normal" tile layer
 --
 -- It gets a reference to its own layer since sometimes the presence
 -- of one property implies the presence or absense of another.
@@ -371,6 +414,11 @@ unwrapPath str f = case parsePath str of
   UnderscoreMapLink -> complain "map links using /_/ are disallowed. Use world:// instead."
   AtMapLink -> complain "map links using /@/ are disallowed. Use world:// instead."
 
+unwrapBadgeToken :: Text -> (BadgeToken -> LintWriter a) -> LintWriter a
+unwrapBadgeToken str f = case parseToken str of
+  Just a  -> f a
+  Nothing -> complain "invalid badge token."
+
 -- | just asserts that this is a string
 isString :: Property -> LintWriter a
 isString = flip unwrapString (const $ pure ())