From 7d8c66b4c3ffd610ef0da98c3f2ff8626f1c8af6 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 2 Dec 2021 02:28:23 +0100 Subject: collect badges from object layers this includes a halfway-reasonable parsing of object layers, as well as some monad plumbing to get them all in the right place. --- lib/Properties.hs | 66 +++++++++++++++++++++++++++++++++++++++++++++++-------- 1 file changed, 57 insertions(+), 9 deletions(-) (limited to 'lib/Properties.hs') 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 ()) -- cgit v1.2.3