diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 74df70a1ab092535e8ebdc15b9db71b10722ecab..bc2decf84cdbc461b769473cfcd3e874c2b3e694 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -16,6 +16,7 @@ module LintWriter
, LintWriter'
, LintResult
, invertLintResult
+ , zoom
-- * working with lint results
, resultToDeps
, resultToOffers
@@ -43,9 +44,9 @@ module LintWriter
import Data.Text (Text)
import Badges (Badge)
-import Control.Monad.State (StateT, modify)
+import Control.Monad.State (StateT, modify, MonadState (put))
import Control.Monad.Trans.Reader (Reader, asks, runReader)
-import Control.Monad.Trans.State (runStateT)
+import Control.Monad.Trans.State (runStateT, get)
import Control.Monad.Writer.Lazy (lift)
import Data.Bifunctor (Bifunctor (second))
import Data.Map (Map, fromListWith)
@@ -86,6 +87,22 @@ runLintWriter config context depth linter = LinterState
$ (depth, context, config)
where runstate = runStateT linter (LinterState ([], context))
+
+zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a
+zoom embed extract operation = do
+ config <- lintConfig id
+ depth <- askFileDepth
+ let result ctxt = runLintWriter config ctxt depth operation
+ LinterState (lints,a) <- get
+ let res = result . extract $ a
+ put $ LinterState
+ . (resultToLints res <> lints,)
+ . embed
+ . resultToAdjusted
+ $ res
+ pure $ resultToAdjusted res
+
+
-- | "invert" a linter's result, grouping lints by their messages
invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
invertLintResult (LinterState (lints, ctxt)) =
diff --git a/lib/Properties.hs b/lib/Properties.hs
index f60758f2362f0e0afd868ea5004b57bfed993e07..1b6cab8aa05857510f0c8f50631aa33eca453d90 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -10,7 +10,7 @@
module Properties (checkMap, checkTileset, checkLayer) where
-import Control.Monad (forM_, unless, when)
+import Control.Monad (forM_, unless, when, forM)
import Data.Text (Text, intercalate, isPrefixOf)
import qualified Data.Text as T
import qualified Data.Vector as V
@@ -26,7 +26,6 @@ import Badges (Badge (Badge),
BadgeArea (BadgePoint, BadgeRect), BadgeToken,
parseToken)
import Data.Data (Proxy (Proxy))
-import Data.Functor ((<&>))
import Data.List ((\\))
import Data.Maybe (fromMaybe, isJust)
import Data.Set (Set)
@@ -36,7 +35,7 @@ import LayerData (Collision, layerOverlaps)
import LintConfig (LintConfig (..))
import LintWriter (LintWriter, adjust, askContext, askFileDepth,
complain, dependsOn, forbid, lintConfig,
- offersBadge, offersEntrypoint, suggest, warn)
+ offersBadge, offersEntrypoint, suggest, warn, zoom)
import Paths (PathResult (..), RelPath (..), getExtension,
isOldStyle, parsePath)
import Types (Dep (Link, Local, LocalMap, MapLink))
@@ -175,6 +174,8 @@ checkTileset = do
where checkTileProperty :: Property -> LintWriter Tileset
checkTileProperty p@(Property name _) = case name of
"collides" -> isBool p
+ -- named tiles are needed for scripting and do not hurt otherwise
+ "name" -> isString p
_ -> warn $ "unknown tile property " <> prettyprint name
<> " in tile with global id "
<> showText (tileId tile)
@@ -195,18 +196,20 @@ checkLayer = do
"group" -> pure ()
"objectgroup" -> do
+
+ -- check object properties
+ objs <- forM (layerObjects layer) $ mapM $ \object -> do
+ -- this is a confusing constant zoom ...
+ zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object)
+ adjust (\l -> l { layerObjects = objs })
+
-- all objects which don't define badges
- publicObjects <- askContext <&>
- fmap (V.filter (not . (`containsProperty` "getBadge"))) . layerObjects
+ let publicObjects = fmap (V.filter (not . (`containsProperty` "getBadge"))) objs
-- remove badges from output
adjust $ \l -> l { layerObjects = publicObjects
, layerProperties = Nothing }
- -- check object properties
- forM_ (fromMaybe mempty (layerObjects layer)) $ \object -> do
- mapM_ (checkObjectProperty object) (getProperties object)
-
-- check layer properties
forM_ (getProperties layer) checkObjectGroupProperty
@@ -223,11 +226,16 @@ checkLayer = do
else when (isJust (layerLayers layer))
$ complain "Layer is not of type \"group\", but has sublayers."
-checkObjectProperty :: Object -> Property -> LintWriter Layer
-checkObjectProperty obj p@(Property name _) = case name of
- "url" -> unwrapURI (Proxy @"website") p
- (dependsOn . Link)
- (const $ forbid "using \"url\" to open local html files is disallowed.")
+checkObjectProperty :: Property -> LintWriter Object
+checkObjectProperty p@(Property name _) = do
+ obj <- askContext
+ case name of
+ "url" -> do
+ unwrapURI (Proxy @"website") p
+ (dependsOn . Link)
+ (const $ forbid "using \"url\" to open local html files is disallowed.")
+ unless (objectType obj == "website")
+ $ complain "\"url\" can only be set for objects of type \"website\""
"allowApi" -> forbidProperty name
"getBadge" -> do
when (1 /= length (getProperties obj))
@@ -247,8 +255,44 @@ checkObjectProperty obj p@(Property name _) = case name of
(Just w, Just h) | w /= 0 && h /= 0 ->
BadgeRect objectX objectY w h
_ -> BadgePoint objectX objectY
- _ -> warn $ "unknown object property " <> prettyprint name <> "."
-
+ "soundRadius" -> do
+ isIntInRange 0 maxBound p
+ unless (containsProperty obj "door" || containsProperty obj "bell")
+ $ complain "property \"soundRadius\" can only be set on objects with \
+ \either property \"bell\" or \"door\" also set."
+
+ _ | name `elem` [ "default", "persist" ] -> do
+ isBool p
+ suggestPropertyName' "door"
+ -- extended API for doors and bells
+ | name `elem` [ "openLayer", "closeLayer" ] -> do
+ isString p
+ suggestPropertyName' "door"
+ -- extended API for doors and bells
+ | name `elem` ["door", "bell"] -> do
+ isBool p
+ unless (objectType obj == "variable") $
+ complain $ "the "<>prettyprint name<>" property should only be set \
+ \on objects of type \"variable\""
+ when (null (objectName obj) || objectName obj == Just mempty) $
+ complain $ "Objects with the property "<>prettyprint name<>" set must \
+ \be named."
+ | name `elem` [ "openSound", "closeSound", "bellSound" ] -> do
+ isString p
+ unwrapURI (Proxy @"audio") p
+ (dependsOn . Link)
+ (dependsOn . Local)
+ case name of
+ "bellSound" ->
+ suggestPropertyName' "bell"
+ "closeSound" | containsProperty obj "openSound" ->
+ suggestPropertyName' "door"
+ _ -> do
+ suggestPropertyName' "door"
+ suggestPropertyName "soundRadius"
+ "set \"soundRadius\" to limit the door sound to a certain area."
+ | otherwise ->
+ warn $ "unknown object property " <> prettyprint name <> "."
-- | Checks a single (custom) property of an objectgroup layer
checkObjectGroupProperty :: Property -> LintWriter Layer
@@ -392,8 +436,24 @@ checkTileLayerProperty p@(Property name _value) = case name of
-- False -> warn "property \"collides\" set to 'false' is useless."
"getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \
\ layer; it does not work on tile layers."
+
+ -- extended API stuff
+ "zone" -> do
+ isString p
+ uselessEmptyLayer
+ -- name on tile layer unsupported
"name" -> isUnsupported
- _ ->
+ _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ]
+ -> do { isString p; requireProperty "zone" }
+ | name `elem` [ "code", "openTriggerMessage", "closeTriggerMessage"]
+ -> do { isString p; requireProperty "doorVariable" }
+ | name `elem` [ "autoOpen", "autoClose"]
+ -> do { isBool p; requireProperty "doorVariable" }
+ | name `elem` [ "bellButtonText", "bellPopup" ]
+ -> do { isString p; requireProperty "bellVariable" }
+ | name `elem` [ "enterValue", "leaveValue" ]
+ -> do { isString p; requireProperty "bindVariable" }
+ | otherwise ->
warn $ "unknown property type " <> prettyprint name
where
isForbidden = forbidProperty name
@@ -485,7 +545,7 @@ whenLayerCollisions layers f andthen = do
----- Functions with concrete lint messages -----
-- | this property is forbidden and should not be used
-forbidProperty :: Text -> LintWriter Layer
+forbidProperty :: HasProperties a => Text -> LintWriter a
forbidProperty name = do
forbid $ "property " <> prettyprint name <> " is disallowed."
@@ -497,12 +557,21 @@ propertyRequiredBy req by =
-- | suggest some value for another property if that property does not
-- also already exist
-suggestProperty :: Property -> LintWriter Layer
-suggestProperty (Property name value) =
- unlessHasProperty name
- $ suggest $ "set property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"."
+suggestProperty :: HasProperties a => Property -> LintWriter a
+suggestProperty p@(Property name value) =
+ suggestProperty' p $ "set property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"."
+suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a
+suggestProperty' (Property name _) msg =
+ unlessHasProperty name (suggest msg)
+suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a
+suggestPropertyName name msg =
+ unlessHasProperty name (suggest msg)
+
+suggestPropertyName' :: HasProperties a => Text -> LintWriter a
+suggestPropertyName' name = suggestPropertyName name
+ $ "consider setting property " <> prettyprint name <> "."
---- Functions for adjusting the context -----
@@ -573,16 +642,17 @@ unwrapBadgeToken str f = case parseToken str of
-- | unwraps a URI
-unwrapURI' :: (KnownSymbol s)
+unwrapURI :: (KnownSymbol s, HasProperties a)
=> Proxy s
-> Property
-> (Text -> LintWriter a)
-> (RelPath -> LintWriter a)
-> LintWriter a
-unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do
+unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
subst <- lintConfig configUriSchemas
case applySubst sym subst link of
Right uri -> do
+ setProperty name uri
f uri
Left NotALink -> unwrapPath link g
Left err -> complain $ case err of
@@ -598,15 +668,6 @@ unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do
<> intercalate ", " (fmap (<> "://") allowed) <> "."
VarsDisallowed -> "extended API links are disallowed in links"
--- | unwraps a URI and adjusts the linter's output
-unwrapURI :: (KnownSymbol s, HasProperties a)
- => Proxy s
- -> Property
- -> (Text -> LintWriter a)
- -> (RelPath -> LintWriter a)
- -> LintWriter a
-unwrapURI sym p@(Property name _) f =
- unwrapURI' sym p $ \uri -> setProperty name uri >> f uri
-- | just asserts that this is a string