Skip to content
Snippets Groups Projects
Commit f3d0f937 authored by stuebinm's avatar stuebinm
Browse files

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)
parent e2767b3b
No related branches found
No related tags found
1 merge request!1Extended scripts support
Hide whitespace changes
Inline Side-by-side
Showing
with 76 additions and 152 deletions
lib/Properties.hs
+ 76
− 152
View file @ f3d0f937
......@@ -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
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment

Impressum - Datenschutzerklärung