summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorstuebinm2021-12-22 19:34:52 +0100
committerstuebinm2021-12-22 19:35:43 +0100
commitf3d0f937f8b5ae09a5a175daf72fda253627a116 (patch)
tree07df7067b855eacffe0478eba7f798d15cf9cd70
parente2767b3b80cab6cd95831cb7045a496f4916ae9b (diff)
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)
-rw-r--r--lib/Properties.hs228
1 files 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