summaryrefslogtreecommitdiff
path: root/lib/Properties.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Properties.hs')
-rw-r--r--lib/Properties.hs157
1 files changed, 94 insertions, 63 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 405e984..0805a4d 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -3,13 +3,13 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Contains checks for custom properties of the map json
-module Properties (checkProperty) where
+module Properties (checkLayerProperty, checkMapProperty) where
import Control.Monad (unless, when)
import Data.Text (Text, isPrefixOf)
import Tiled2 (Layer (layerProperties), Property (..),
- PropertyValue (..))
+ PropertyValue (..), Tiledmap)
import Util (layerIsEmpty, prettyprint)
import LintWriter (LintWriter, complain, dependsOn, forbid, info,
@@ -29,97 +29,80 @@ import Types (Dep (Link, Local, LocalMap, MapLink))
--
-- I've attempted to build the LintWriter monad in a way
-- that should make this readable even to non-Haskellers
-checkProperty :: Layer -> Property -> LintWriter ()
-checkProperty layer (Property name value) = case name of
+checkLayerProperty :: Layer -> Property -> LintWriter ()
+checkLayerProperty layer p@(Property name value) = case name of
"jitsiRoom" -> do
uselessEmptyLayer
- unwrapString $ \val -> do
+ unwrapString p $ \val -> do
info $ "found jitsi room: " <> prettyprint val
- suggestPropertyValue "jitsiTrigger" "onaction"
+ suggestProp $ Property "jitsiTrigger" (StrProp "onaction")
"jitsiTrigger" -> do
- isString
- unless (hasProperty "jitsiTriggerMessage" layer)
+ isString p
+ unless (hasProperty "jitsiTriggerMessage")
$ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
- requireProperty "jitsiRoom"
+ requireProp "jitsiRoom"
"jitsiTriggerMessage" -> do
- isString
- requireProperty "jitsiTrigger"
+ isString p
+ requireProp "jitsiTrigger"
"jitsiUrl" -> isForbidden
"jitsiConfig" -> isForbidden
"jitsiClientConfig" -> isForbidden
"jitsiRoomAdminTag" -> isForbidden
"playAudio" -> do
uselessEmptyLayer
- unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link
then Link link
else Local link
"audioLoop" -> do
- isBool
- requireProperty "playAudio"
+ isBool p
+ requireProp "playAudio"
"audioVolume" -> do
- isBool
- requireProperty "playAudio"
+ isBool p
+ requireProp "playAudio"
"openWebsite" -> do
uselessEmptyLayer
- suggestPropertyValue "openWebsiteTrigger" "onaction"
- unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ suggestProp $ Property "openWebsiteTrigger" (StrProp "onaction")
+ unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link
then Link link
else Local link
"openWebsiteTrigger" -> do
- isString
- unless (hasProperty "openWebsiteTriggerMessage" layer)
+ isString p
+ unless (hasProperty "openWebsiteTriggerMessage")
$ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\""
- requireProperty "openWebsite"
+ requireProp "openWebsite"
"openWebsiteTriggerMessage" -> do
- isString
- requireProperty "openWebsiteTrigger"
+ isString p
+ requireProp "openWebsiteTrigger"
"openWebsitePolicy" -> do
- isString
- requireProperty "openWebsite"
+ isString p
+ requireProp "openWebsite"
"openTab" -> do
- isString
- requireProperty "openWebsite"
+ isString p
+ requireProp "openWebsite"
"url" -> isForbidden
"allowApi" -> isForbidden
"exitUrl" -> do
forbidEmptyLayer
- unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link
then MapLink link
else LocalMap link
"startLayer" -> do
forbidEmptyLayer
- unwrapBool $ \case
+ unwrapBool p $ \case
True -> pure ()
False -> complain "startLayer must be set to true"
"silent" -> do
- isBool
+ isBool p
uselessEmptyLayer
_ ->
complain $ "unknown property type " <> prettyprint name
where
+ properties = layerProperties layer
+ hasProperty = containsProperty properties
+ isForbidden = forbidProperty name
+ requireProp = requireProperty properties
+ suggestProp = suggestPropertyValue properties
- -- | asserts that this property is a string, and unwraps it
- unwrapString f = case value of
- StrProp str -> f str
- _ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
- -- | same as unwrapString, but also forbids http:// as prefix
- unwrapLink f = case value of
- StrProp str -> if "http://" `isPrefixOf` str
- then complain "cannot access content via http; either use https or include it locally instead."
- else f str
- _ -> complain $ "type mismatch in property " <> name <> "; should be of typ string"
- -- | asserts that this property is a boolean, and unwraps it
- unwrapBool f = case value of
- BoolProp b -> f b
- _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
- -- | just asserts that this is a string
- isString = unwrapString (const $ pure ())
- -- | just asserts that this is a boolean
- isBool = unwrapBool (const $ pure ())
-
-
- -- | this property is forbidden and should not be used
- isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
-- | this property can only be used on a layer that contains at least one tiles
forbidEmptyLayer = when (layerIsEmpty layer)
$ complain ("property " <> name <> " should not be set on an empty layer")
@@ -127,19 +110,67 @@ checkProperty layer (Property name value) = case name of
uselessEmptyLayer = when (layerIsEmpty layer)
$ warn ("property" <> name <> " was set on an empty layer and is thereby useless")
- -- | require some property in this layer
- requireProperty name = unless (hasProperty name layer)
- $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
- -- | suggest a certain value for some other property in this layer
- suggestPropertyValue :: Text -> Text -> LintWriter ()
- suggestPropertyValue name value = unless (hasProperty name layer)
- $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
+-- | Checks a single property of a map.
+--
+-- Doesn't really do all that much, but could in theory be expanded into a
+-- longer function same as checkLayerProperty.
+checkMapProperty :: Tiledmap -> Property -> LintWriter ()
+checkMapProperty map (Property name value) = case name of
+ "script" -> isForbidden
+ _ -> complain $ "unknown map property " <> name
+ where
+ -- | this property is forbidden and should not be used
+ isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
+
-- | does this layer have the given property?
-hasProperty :: Text -> Layer -> Bool
-hasProperty name = any
- (\(Property name' _) -> name' == name)
- . layerProperties
+containsProperty :: [Property] -> Text -> Bool
+containsProperty props name = any
+ (\(Property name' _) -> name' == name) props
+
+-- | this property is forbidden and should not be used
+forbidProperty :: Text -> LintWriter ()
+forbidProperty name = forbid $ "property " <> prettyprint name <> " should not be used"
+
+
+-- | asserts that this property is a string, and unwraps it
+unwrapString :: Property -> (Text -> LintWriter ()) -> LintWriter ()
+unwrapString (Property name value) f = case value of
+ StrProp str -> f str
+ _ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
+
+-- | same as unwrapString, but also forbids http:// as prefix
+unwrapLink :: Property -> (Text -> LintWriter ()) -> LintWriter ()
+unwrapLink (Property name value) f = case value of
+ StrProp str -> if "http://" `isPrefixOf` str
+ then complain "cannot access content via http; either use https or include it locally instead."
+ else f str
+ _ -> complain $ "type mismatch in property " <> name <> "; should be of typ string"
+
+-- | asserts that this property is a boolean, and unwraps it
+unwrapBool :: Property -> (Bool -> LintWriter ()) -> LintWriter ()
+unwrapBool (Property name value) f = case value of
+ BoolProp b -> f b
+ _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
+
+-- | just asserts that this is a string
+isString :: Property -> LintWriter ()
+isString = flip unwrapString (const $ pure ())
+
+-- | just asserts that this is a boolean
+isBool :: Property -> LintWriter ()
+isBool = flip unwrapBool (const $ pure ())
+
+-- | require some property
+requireProperty :: [Property] -> Text -> LintWriter ()
+requireProperty props name = unless (containsProperty props name)
+ $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
+
+-- | suggest soem value for another property if that property does not
+-- also already exist
+suggestPropertyValue :: [Property] -> Property -> LintWriter ()
+suggestPropertyValue props (Property name value) = unless (containsProperty props name)
+ $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-01 13:01:19 +0000