From 22ff0a5b31900bc761a25a10db7dcbb197f44e94 Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Sun, 19 Dec 2021 17:13:50 +0100 Subject: Lint door stuff --- lib/Properties.hs | 88 ++++++++++++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 87 insertions(+), 1 deletion(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index a326e30..65f1822 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -175,6 +175,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) @@ -225,7 +227,10 @@ checkLayer = do checkObjectProperty :: Object -> Property -> LintWriter Layer checkObjectProperty obj p@(Property name _) = case name of - "url" -> pure () + "url" -> do + pure () + 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)) @@ -245,7 +250,59 @@ checkObjectProperty obj p@(Property name _) = case name of (Just w, Just h) | w /= 0 && h /= 0 -> BadgeRect objectX objectY w h _ -> BadgePoint objectX objectY + + -- | these properties are used by the extended script to allow doors + "door" -> do + isBool p + unless (objectType obj == "variable") $ + complain "Door variables must be of type \"variable\"" + when (null (objectName obj) || objectName obj == Just mempty) $ + complain "Door variables objects must have a name given" + + "default" -> do + isBool p + requireProperty "door" + "persist" -> do + isBool p + requireProperty "door" + "openLayer" -> do + isString p + requireProperty "door" + "closeLayer" -> do + isString p + requireProperty "door" + "openSound" -> do + isString p + + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + + unless (containsProperty obj "soundRadius") + $ suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." + + requireProperty "door" + "closeSound" -> do + isString p + + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + + requireProperty "door" + "soundRadius" -> do + isInt p + + unless (containsProperty obj "soundRadius") + $ suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." + + requireProperty "door" + _ -> warn $ "unknown object property " <> prettyprint name <> "." + where + requireProperty req = do + unless (containsProperty obj req) $ + complain( "property " <> prettyprint req <> " is required by property " <> prettyprint name <> ".") -- | Checks a single (custom) property of an objectgroup layer @@ -384,6 +441,31 @@ 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." + + -- | these properties are used by the extended script to allow doors + "zone" -> do + isString p + uselessEmptyLayer + "doorVariable" -> do + isString p + requireProperty "zone" + "autoOpen" -> do + isBool p + requireProperty "zone" + "autoClose" -> do + isBool p + requireProperty "zone" + "code" -> do + isString p + requireProperty "zone" + "openTriggerMessage" -> do + isString p + requireProperty "zone" + "closeTriggerMessage" -> do + isString p + requireProperty "zone" + + -- name on tile layer unsupported "name" -> isUnsupported _ -> warn $ "unknown property type " <> prettyprint name @@ -592,6 +674,10 @@ isString = flip unwrapString (const $ pure ()) isBool :: Property -> LintWriter a isBool = flip unwrapBool (const $ pure ()) +-- | just asserts that this is a int +isInt:: Property -> LintWriter a +isInt = flip unwrapInt (const $ pure ()) + isIntInRange :: Int -> Int -> Property -> LintWriter b isIntInRange = isOrdInRange @Int unwrapInt -- cgit v1.2.3 From 9bc7b9bdbb044815712d75b969e7325b388a0f72 Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Sun, 19 Dec 2021 19:13:29 +0100 Subject: Only suggert door properties on variables --- lib/Properties.hs | 30 +++++++++++++++--------------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 65f1822..4a16927 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -261,16 +261,16 @@ checkObjectProperty obj p@(Property name _) = case name of "default" -> do isBool p - requireProperty "door" + suggestProperty "door" "persist" -> do isBool p - requireProperty "door" + suggestProperty "door" "openLayer" -> do isString p - requireProperty "door" + suggestProperty "door" "closeLayer" -> do isString p - requireProperty "door" + suggestProperty "door" "openSound" -> do isString p @@ -278,10 +278,10 @@ checkObjectProperty obj p@(Property name _) = case name of (dependsOn . Link) (dependsOn . Local) - unless (containsProperty obj "soundRadius") - $ suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." + unless (containsProperty obj "soundRadius") $ + suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." - requireProperty "door" + suggestProperty "door" "closeSound" -> do isString p @@ -289,21 +289,21 @@ checkObjectProperty obj p@(Property name _) = case name of (dependsOn . Link) (dependsOn . Local) - requireProperty "door" + unless (containsProperty obj "soundRadius") $ + -- Do not suggest again if already suggested for openSound + unless (containsProperty obj "openSound") $ + suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." + + suggestProperty "door" "soundRadius" -> do isInt p - unless (containsProperty obj "soundRadius") - $ suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." - - requireProperty "door" _ -> warn $ "unknown object property " <> prettyprint name <> "." where - requireProperty req = do + suggestProperty req = do unless (containsProperty obj req) $ - complain( "property " <> prettyprint req <> " is required by property " <> prettyprint name <> ".") - + suggest( "property " <> prettyprint req <> " is suggested for property " <> prettyprint name <> ".") -- | Checks a single (custom) property of an objectgroup layer checkObjectGroupProperty :: Property -> LintWriter Layer -- cgit v1.2.3 From 864235b3222563dceace6e8981cba6e7145585f9 Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Sun, 19 Dec 2021 19:14:12 +0100 Subject: Added bell properties --- lib/Properties.hs | 40 ++++++++++++++++++++++++++++++++++++---- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 4a16927..7fc58c9 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -295,8 +295,27 @@ checkObjectProperty obj p@(Property name _) = case name of suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." suggestProperty "door" + + -- | these properties are used by the extended script to allow doors + "bell" -> do + isBool p + unless (objectType obj == "variable") $ + complain "Bell variables must be of type \"variable\"" + when (null (objectName obj) || objectName obj == Just mempty) $ + complain "Bell variables objects must have a name given" + "bellSound" -> do + isString p + + unwrapURI (Proxy @"audio") p + (dependsOn . Link) + (dependsOn . Local) + + suggestProperty "bell" + + -- | Applies to doors and bells as well "soundRadius" -> do isInt p + -- requireAnyProperty "door" "bell" _ -> warn $ "unknown object property " <> prettyprint name <> "." @@ -451,19 +470,32 @@ checkTileLayerProperty p@(Property name _value) = case name of requireProperty "zone" "autoOpen" -> do isBool p - requireProperty "zone" + requireProperty "doorVariable" "autoClose" -> do isBool p - requireProperty "zone" + requireProperty "doorVariable" "code" -> do isString p - requireProperty "zone" + requireProperty "doorVariable" "openTriggerMessage" -> do isString p - requireProperty "zone" + requireProperty "doorVariable" "closeTriggerMessage" -> do + isString p + requireProperty "doorVariable" + + -- | these properties are used by the extended script to allow bells + + "bellVariable" -> do isString p requireProperty "zone" + "bellButtonText" -> do + isString p + requireProperty "bellVariable" + "bellPopup" -> do + isString p + requireProperty "bellVariable" + -- name on tile layer unsupported "name" -> isUnsupported -- cgit v1.2.3 From 8f5af0492e7a82192d1fafda3d2c74421af4354d Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Sun, 19 Dec 2021 20:11:55 +0100 Subject: Wrap urls for inline iframes --- lib/Properties.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/lib/Properties.hs b/lib/Properties.hs index 7fc58c9..25bbbd3 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -229,6 +229,9 @@ checkObjectProperty :: Object -> Property -> LintWriter Layer checkObjectProperty obj p@(Property name _) = case name of "url" -> do pure () + unwrapURI (Proxy @"website") p + (dependsOn . Link) + (dependsOn . Local) unless (objectType obj == "website") $ complain "\"url\" can only be set for objects of type \"website\"" "allowApi" -> forbidProperty name -- cgit v1.2.3 From 76073dd28c46f59c247f09846f43bd92c016f8af Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Mon, 20 Dec 2021 00:42:50 +0100 Subject: Added extended script action zone properties --- lib/Properties.hs | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/lib/Properties.hs b/lib/Properties.hs index 551c502..75b69ae 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -499,6 +499,17 @@ checkTileLayerProperty p@(Property name _value) = case name of isString p requireProperty "bellVariable" + -- | these properties are used by the extended script to allow action zones¶ + "bindVariable" -> do + isString p + requireProperty "zone" + "enterValue" -> do + isString p + requireProperty "bindVariable" + "leaveValue" -> do + isString p + requireProperty "bindVariable" + -- name on tile layer unsupported "name" -> isUnsupported -- cgit v1.2.3 From 7709a44520aabdfe4657c0abff3a5acc40bedc0f Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Mon, 20 Dec 2021 12:03:05 +0100 Subject: Resolved merge conflict --- lib/Properties.hs | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 970424a..0eaa245 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -227,14 +227,10 @@ checkLayer = do 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.") "url" -> do - pure () unwrapURI (Proxy @"website") p (dependsOn . Link) - (dependsOn . Local) + (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 -- cgit v1.2.3 From 2ffe06300acdfbfecde7e7c1b5e4006544ef9b2b Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Tue, 21 Dec 2021 22:23:09 +0100 Subject: Did some of the desired changes --- lib/Properties.hs | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 1c81f87..62cb4f7 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -228,9 +228,12 @@ checkLayer = do checkObjectProperty :: Object -> Property -> LintWriter Layer checkObjectProperty obj p@(Property name _) = case name of "url" -> do - unwrapURI (Proxy @"website") p + unwrapURI' (Proxy @"website") p (dependsOn . Link) (const $ forbid "using \"url\" to open local html files is disallowed.") + + -- | TODO: The uri should be rewritten if the unwrapURI' did add the wrapper + unless (objectType obj == "website") $ complain "\"url\" can only be set for objects of type \"website\"" "allowApi" -> forbidProperty name @@ -257,7 +260,7 @@ checkObjectProperty obj p@(Property name _) = case name of "door" -> do isBool p unless (objectType obj == "variable") $ - complain "Door variables must be of type \"variable\"" + complain "the \"door\" property should only be set on objects of type \"variable\"" when (null (objectName obj) || objectName obj == Just mempty) $ complain "Door variables objects must have a name given" @@ -276,7 +279,7 @@ checkObjectProperty obj p@(Property name _) = case name of "openSound" -> do isString p - unwrapURI (Proxy @"audio") p + unwrapURI' (Proxy @"audio") p (dependsOn . Link) (dependsOn . Local) @@ -287,7 +290,7 @@ checkObjectProperty obj p@(Property name _) = case name of "closeSound" -> do isString p - unwrapURI (Proxy @"audio") p + unwrapURI' (Proxy @"audio") p (dependsOn . Link) (dependsOn . Local) @@ -302,13 +305,13 @@ checkObjectProperty obj p@(Property name _) = case name of "bell" -> do isBool p unless (objectType obj == "variable") $ - complain "Bell variables must be of type \"variable\"" + complain "the \"bell\" property should only be set on objects of type \"variable\"" when (null (objectName obj) || objectName obj == Just mempty) $ complain "Bell variables objects must have a name given" "bellSound" -> do isString p - unwrapURI (Proxy @"audio") p + unwrapURI' (Proxy @"audio") p (dependsOn . Link) (dependsOn . Local) @@ -317,7 +320,7 @@ checkObjectProperty obj p@(Property name _) = case name of -- | Applies to doors and bells as well "soundRadius" -> do isInt p - -- requireAnyProperty "door" "bell" + -- | maybe we should lint that this property is only used on door and bell variables _ -> warn $ "unknown object property " <> prettyprint name <> "." -- cgit v1.2.3 From e2767b3b80cab6cd95831cb7045a496f4916ae9b Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 22 Dec 2021 19:34:21 +0100 Subject: add zoom function for LintWriter --- lib/LintWriter.hs | 21 +++++++++++++++++++-- 1 file changed, 19 insertions(+), 2 deletions(-) diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index 74df70a..bc2decf 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)) = -- cgit v1.2.3 From f3d0f937f8b5ae09a5a175daf72fda253627a116 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Wed, 22 Dec 2021 19:34:52 +0100 Subject: shorten Properties.hs down almost 100 lines of code! (and hopefully denotationally equivalent, except for the bits about where it was wrong before and didn't replace uris correctly) --- lib/Properties.hs | 228 ++++++++++++++++++------------------------------------ 1 file changed, 76 insertions(+), 152 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 62cb4f7..6f53c48 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)) @@ -197,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 @@ -225,15 +226,14 @@ 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 +checkObjectProperty :: Property -> LintWriter Object +checkObjectProperty p@(Property name _) = do + obj <- askContext + case name of "url" -> do - unwrapURI' (Proxy @"website") p + unwrapURI (Proxy @"website") p (dependsOn . Link) (const $ forbid "using \"url\" to open local html files is disallowed.") - - -- | TODO: The uri should be rewritten if the unwrapURI' did add the wrapper - unless (objectType obj == "website") $ complain "\"url\" can only be set for objects of type \"website\"" "allowApi" -> forbidProperty name @@ -255,79 +255,40 @@ checkObjectProperty obj p@(Property name _) = case name of (Just w, Just h) | w /= 0 && h /= 0 -> BadgeRect objectX objectY w h _ -> BadgePoint objectX objectY - - -- | these properties are used by the extended script to allow doors - "door" -> do - isBool p - unless (objectType obj == "variable") $ - complain "the \"door\" property should only be set on objects of type \"variable\"" - when (null (objectName obj) || objectName obj == Just mempty) $ - complain "Door variables objects must have a name given" - - "default" -> do - isBool p - suggestProperty "door" - "persist" -> do - isBool p - suggestProperty "door" - "openLayer" -> do - isString p - suggestProperty "door" - "closeLayer" -> do - isString p - suggestProperty "door" - "openSound" -> do - isString p - - unwrapURI' (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - - unless (containsProperty obj "soundRadius") $ - suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." - - suggestProperty "door" - "closeSound" -> do - isString p - - unwrapURI' (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - - unless (containsProperty obj "soundRadius") $ - -- Do not suggest again if already suggested for openSound - unless (containsProperty obj "openSound") $ - suggest "set \"soundRadius\" to a limit the door sound to a certain area\"." - - suggestProperty "door" - - -- | these properties are used by the extended script to allow doors - "bell" -> do - isBool p - unless (objectType obj == "variable") $ - complain "the \"bell\" property should only be set on objects of type \"variable\"" - when (null (objectName obj) || objectName obj == Just mempty) $ - complain "Bell variables objects must have a name given" - "bellSound" -> do - isString p - - unwrapURI' (Proxy @"audio") p - (dependsOn . Link) - (dependsOn . Local) - - suggestProperty "bell" - - -- | Applies to doors and bells as well "soundRadius" -> do - isInt p - -- | maybe we should lint that this property is only used on door and bell variables - - - _ -> warn $ "unknown object property " <> prettyprint name <> "." - where - suggestProperty req = do - unless (containsProperty obj req) $ - suggest( "property " <> prettyprint req <> " is suggested for property " <> prettyprint name <> ".") + 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", "openLayer", "closeLayer" ] -> do + isBool 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 @@ -472,56 +433,22 @@ checkTileLayerProperty p@(Property name _value) = case name of "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \ \ layer; it does not work on tile layers." - -- | these properties are used by the extended script to allow doors + -- extended API stuff "zone" -> do isString p uselessEmptyLayer - "doorVariable" -> do - isString p - requireProperty "zone" - "autoOpen" -> do - isBool p - requireProperty "doorVariable" - "autoClose" -> do - isBool p - requireProperty "doorVariable" - "code" -> do - isString p - requireProperty "doorVariable" - "openTriggerMessage" -> do - isString p - requireProperty "doorVariable" - "closeTriggerMessage" -> do - isString p - requireProperty "doorVariable" - - -- | these properties are used by the extended script to allow bells - - "bellVariable" -> do - isString p - requireProperty "zone" - "bellButtonText" -> do - isString p - requireProperty "bellVariable" - "bellPopup" -> do - isString p - requireProperty "bellVariable" - - -- | these properties are used by the extended script to allow action zones¶ - "bindVariable" -> do - isString p - requireProperty "zone" - "enterValue" -> do - isString p - requireProperty "bindVariable" - "leaveValue" -> do - isString p - requireProperty "bindVariable" - - -- name on tile layer unsupported "name" -> isUnsupported - _ -> + _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ] + -> do { isString p; requireProperty "zone" } + | name `elem` [ "autoOpen", "autoClose", "code" + , "openTriggerMessage", "closeTriggerMessage"] + -> do { isString 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 @@ -613,7 +540,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." @@ -625,12 +552,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 ----- @@ -701,16 +637,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 @@ -726,15 +663,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 @@ -745,10 +673,6 @@ isString = flip unwrapString (const $ pure ()) isBool :: Property -> LintWriter a isBool = flip unwrapBool (const $ pure ()) --- | just asserts that this is a int -isInt:: Property -> LintWriter a -isInt = flip unwrapInt (const $ pure ()) - isIntInRange :: Int -> Int -> Property -> LintWriter b isIntInRange = isOrdInRange @Int unwrapInt -- cgit v1.2.3 From c82e15aebf3c9d88116be75082d938be8c4d635e Mon Sep 17 00:00:00 2001 From: Sven G. Brönstrup Date: Wed, 22 Dec 2021 20:58:11 +0100 Subject: Fixed types of extended scripts properties --- lib/Properties.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/lib/Properties.hs b/lib/Properties.hs index 6f53c48..1b6cab8 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -261,10 +261,14 @@ checkObjectProperty p@(Property name _) = do $ complain "property \"soundRadius\" can only be set on objects with \ \either property \"bell\" or \"door\" also set." - _ | name `elem` [ "default", "persist", "openLayer", "closeLayer" ] -> do + _ | 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") $ @@ -441,9 +445,10 @@ checkTileLayerProperty p@(Property name _value) = case name of "name" -> isUnsupported _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ] -> do { isString p; requireProperty "zone" } - | name `elem` [ "autoOpen", "autoClose", "code" - , "openTriggerMessage", "closeTriggerMessage"] + | 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" ] -- cgit v1.2.3