From f3d0f937f8b5ae09a5a175daf72fda253627a116 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Wed, 22 Dec 2021 19:34:52 +0100
Subject: [PATCH] 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
--
GitLab