From 968038c403e71b98a8f55a4d79e64beca8349ab3 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Mon, 20 Sep 2021 01:26:27 +0200
Subject: [PATCH] lint general map properties
---
lib/CheckMap.hs | 19 ++++--
lib/LintWriter.hs | 13 +++-
lib/Properties.hs | 157 +++++++++++++++++++++++++++-------------------
lib/Tiled2.hs | 4 +-
4 files changed, 121 insertions(+), 72 deletions(-)
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 9908fdd..08932b4 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -17,10 +17,12 @@ import qualified Data.Vector as V
import GHC.Generics (Generic)
import LintWriter (LintResult (..), LintWriter,
- lintsToDeps)
-import Properties (checkProperty)
+ lintsToDeps, resultToLints,
+ runLintWriter)
+import Properties (checkLayerProperty,
+ checkMapProperty)
import Tiled2 (Layer (layerName, layerProperties),
- Tiledmap (tiledmapLayers),
+ Tiledmap (tiledmapLayers, tiledmapProperties),
loadTiledmap)
import Types (Dep, Level (..), Lint (..), hint,
lintLevel)
@@ -55,7 +57,7 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case
runLinter :: Tiledmap -> MapResult ()
runLinter tiledmap = MapResult
{ mapresultLayer = Just layerMap
- , mapresultGeneral = [] -- no general lints for now
+ , mapresultGeneral = propertyLints -- no general lints for now
, mapresultDepends = concatMap (lintsToDeps . snd) layer
}
where
@@ -64,10 +66,15 @@ runLinter tiledmap = MapResult
layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
+ -- lints collected from properties
+ propertyLints = runLintWriter
+ $ mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap)
+
+
-- | collect lints on a single map layer
checkLayer :: Layer -> LintWriter ()
checkLayer layer =
- mapM_ (checkProperty layer) (layerProperties layer)
+ mapM_ (checkLayerProperty layer) (layerProperties layer)
-- human-readable lint output, e.g. for consoles
instance PrettyPrint a => PrettyPrint (MapResult a) where
@@ -79,7 +86,7 @@ instance PrettyPrint a => PrettyPrint (MapResult a) where
(uncurry showResult)
(maybe [] toList . mapresultLayer $ mapResult)
prettyGeneral :: [Text]
- prettyGeneral = prettyprint <$> mapresultGeneral mapResult
+ prettyGeneral = flip (<>) "\n" . prettyprint <$> mapresultGeneral mapResult
-- TODO: possibly expand this to something more detailed?
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 055e2d4..02815e3 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -9,7 +9,8 @@ module LintWriter where
import Control.Monad.Trans.Maybe ()
import Control.Monad.Writer (MonadTrans (lift),
- MonadWriter (tell), WriterT)
+ MonadWriter (tell), WriterT,
+ runWriterT)
import Data.Aeson (ToJSON (toJSON))
import Data.Text (Text)
@@ -45,6 +46,16 @@ lintsToDeps (LintResult a) = case a of
Left _ -> []
Right (_, lints) -> mapMaybe lintToDep lints
+-- | convert a lint result into a flat list of lints
+-- (throwing away information on if a single error was fatal)
+resultToLints :: LintResult a -> [Lint]
+resultToLints (LintResult res) = case res of
+ Left l -> [l]
+ Right (_, lints) -> lints
+
+-- | Confusingly, this returns lints, not a …
+runLintWriter :: LintWriter a -> [Lint]
+runLintWriter = resultToLints . LintResult . runWriterT
-- | write a hint into the LintWriter monad
lint :: Level -> Text -> LintWriter ()
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
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 8220bfb..79033f0 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -398,7 +398,7 @@ data Tiledmap = Tiledmap { tiledmapVersion :: Float
-- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional)
, tiledmapRenderorder :: String
-- ^ Rendering direction (orthogonal maps only)
- , tiledmapProperties :: Map Text Text
+ , tiledmapProperties :: [Property]
-- ^ String key-value pairs
, tiledmapNextobjectid :: Int
-- ^ Auto-increments for each placed object
@@ -416,7 +416,7 @@ instance FromJSON Tiledmap where
<*> o .: "tilesets"
<*> (o .: "backgroundcolor" <|> pure Nothing)
<*> o .: "renderorder"
- <*> (o .: "properties" <|> pure mempty)
+ <*> (o .:? "properties" <&> fromMaybe [])
<*> o .: "nextobjectid"
parseJSON invalid = typeMismatch "Tiledmap" invalid
--
GitLab