summaryrefslogtreecommitdiff
path: root/lib/Properties.hs
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Properties.hs120
1 files changed, 67 insertions, 53 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 68cf88a..818378a 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -12,8 +12,8 @@ import Tiled2 (Layer (..), Property (..), PropertyValue (..),
Tiledmap (..), Tileset (..))
import Util (layerIsEmpty, prettyprint)
-import LintWriter (LintWriter, complain, dependsOn, forbid, info,
- suggest, warn, LayerContext)
+import LintWriter (LintWriter, askContext, askFileDepth, complain,
+ dependsOn, forbid, info, suggest, warn)
import Paths
import Types (Dep (Link, Local, LocalMap, MapLink))
@@ -23,11 +23,12 @@ import Types (Dep (Link, Local, LocalMap, MapLink))
-- Note that it does /not/ call checkMapProperty; this is handled
-- seperately in CheckMap.hs, since these lints go into a different
-- field of the resulting json.
-checkMap :: Tiledmap -> LintWriter ()
-checkMap tiledmap = do
- -- check properties
- mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap)
- -- check tilesets
+checkMap :: LintWriter Tiledmap
+checkMap = do
+ tiledmap <- askContext
+
+ -- test other things
+ mapM_ checkMapProperty (tiledmapProperties tiledmap)
mapM_ checkTileset (tiledmapTilesets tiledmap)
-- some layers should exist
@@ -44,10 +45,10 @@ checkMap tiledmap = do
unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
$ complain "The map's tile size must be 32 by 32 pixels"
where
- layers = tiledmapLayers tiledmap
- hasLayerNamed name pred = hasLayer (\l -> layerName l == name && pred l)
- hasLayer pred err =
- unless (any pred layers)
+ hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l)
+ hasLayer p err = do
+ tiledmap <- askContext
+ unless (any p (tiledmapLayers tiledmap))
$ complain err
@@ -55,8 +56,8 @@ checkMap tiledmap = do
--
-- 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
+checkMapProperty :: Property -> LintWriter Tiledmap
+checkMapProperty (Property name _value) = case name of
"script" -> isForbidden
_ -> complain $ "unknown map property " <> name
where
@@ -67,7 +68,7 @@ checkMapProperty map (Property name value) = case name of
-- | check an embedded tile set.
--
-- Important to collect dependency files
-checkTileset :: Tileset -> LintWriter ()
+checkTileset :: Tileset -> LintWriter Tiledmap
checkTileset tileset = do
-- TODO: can tilesets be non-local dependencies?
unwrapPath (tilesetImage tileset) (dependsOn . Local)
@@ -83,21 +84,21 @@ checkTileset tileset = do
--
-- It gets a reference to its own layer since sometimes the presence
-- of one property implies the presence or absense of another.
-checkLayerProperty :: Layer -> Property -> LintWriter LayerContext
-checkLayerProperty layer p@(Property name value) = case name of
+checkLayerProperty :: Property -> LintWriter Layer
+checkLayerProperty p@(Property name _value) = case name of
"jitsiRoom" -> do
uselessEmptyLayer
unwrapString p $ \val -> do
info $ "found jitsi room: " <> prettyprint val
- suggestProp $ Property "jitsiTrigger" (StrProp "onaction")
+ suggestProperty $ Property "jitsiTrigger" (StrProp "onaction")
"jitsiTrigger" -> do
isString p
- unless (hasProperty "jitsiTriggerMessage")
+ unlessHasProperty "jitsiTriggerMessage"
$ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
- requireProp "jitsiRoom"
+ requireProperty "jitsiRoom"
"jitsiTriggerMessage" -> do
isString p
- requireProp "jitsiTrigger"
+ requireProperty "jitsiTrigger"
"jitsiUrl" -> isForbidden
"jitsiConfig" -> isForbidden
"jitsiClientConfig" -> isForbidden
@@ -109,30 +110,30 @@ checkLayerProperty layer p@(Property name value) = case name of
else unwrapPath link (dependsOn . Local)
"audioLoop" -> do
isBool p
- requireProp "playAudio"
+ requireProperty "playAudio"
"audioVolume" -> do
isBool p
- requireProp "playAudio"
+ requireProperty "playAudio"
"openWebsite" -> do
uselessEmptyLayer
- suggestProp $ Property "openWebsiteTrigger" (StrProp "onaction")
+ suggestProperty $ Property "openWebsiteTrigger" (StrProp "onaction")
unwrapLink p $ \link -> if "https://" `isPrefixOf` link
then dependsOn $ Link link
else unwrapPath link (dependsOn . Local)
"openWebsiteTrigger" -> do
isString p
- unless (hasProperty "openWebsiteTriggerMessage")
+ unlessHasProperty "openWebsiteTriggerMessage"
$ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\""
- requireProp "openWebsite"
+ requireProperty "openWebsite"
"openWebsiteTriggerMessage" -> do
isString p
- requireProp "openWebsiteTrigger"
+ requireProperty "openWebsiteTrigger"
"openWebsitePolicy" -> do
isString p
- requireProp "openWebsite"
+ requireProperty "openWebsite"
"openTab" -> do
isString p
- requireProp "openWebsite"
+ requireProperty "openWebsite"
"url" -> isForbidden
"allowApi" -> isForbidden
"exitUrl" -> do
@@ -151,29 +152,53 @@ checkLayerProperty layer p@(Property name value) = case name of
_ ->
complain $ "unknown property type " <> prettyprint name
where
- properties = layerProperties layer
- hasProperty = containsProperty properties
isForbidden = forbidProperty name
- requireProp = requireProperty properties
- suggestProp = suggestPropertyValue properties
-- | 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")
+ forbidEmptyLayer = do
+ layer <- askContext
+ when (layerIsEmpty layer)
+ $ complain ("property " <> name <> " should not be set on an empty layer")
-- | this layer is allowed, but also useless on a layer that contains no tiles
- uselessEmptyLayer = when (layerIsEmpty layer)
- $ warn ("property" <> name <> " was set on an empty layer and is thereby useless")
+ uselessEmptyLayer = do
+ layer <- askContext
+ when (layerIsEmpty layer)
+ $ warn ("property" <> name <> " was set on an empty layer and is thereby useless")
+--------- Helper functions & stuff ---------
+unlessHasProperty :: Text -> LintWriter Layer -> LintWriter Layer
+unlessHasProperty name andthen = do
+ layer <- askContext
+ let hasprop = any (\(Property name' _) -> name == name') (layerProperties layer)
+ unless hasprop andthen
+-- | this property is forbidden and should not be used
+forbidProperty :: Text -> LintWriter Layer
+forbidProperty name = do
+ forbid $ "property " <> prettyprint name <> " should not be used"
+
+
+-- | require some property
+requireProperty :: Text -> LintWriter Layer
+requireProperty name =
+ unlessHasProperty name
+ $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
+
+-- | 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
+
---------- Helper functions & stuff ---------
-- | does this layer have the given property?
@@ -181,10 +206,6 @@ 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 a
-forbidProperty name = forbid $ "property " <> prettyprint name <> " should not be used"
-
-- | asserts that this property is a string, and unwraps it
unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
@@ -208,7 +229,11 @@ unwrapBool (Property name value) f = case value of
unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
unwrapPath str f = case parsePath str of
- Just path -> f path
+ Just p@(Path up _) -> do
+ depth <- askFileDepth
+ if up <= depth
+ then f p
+ else complain $ "cannot acess paths \"" <> str <> "\" which is outside your repository"
Nothing -> complain $ "path \"" <> str <> "\" is invalid"
-- | just asserts that this is a string
@@ -218,14 +243,3 @@ isString = flip unwrapString (const $ pure ())
-- | just asserts that this is a boolean
isBool :: Property -> LintWriter a
isBool = flip unwrapBool (const $ pure ())
-
--- | require some property
-requireProperty :: [Property] -> Text -> LintWriter a
-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 a
-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-11-07 00:08:38 +0000