From 33d2b0c5da01c48c8106876665e646e1d2f560e9 Mon Sep 17 00:00:00 2001
From: stuebinm <stuebinm@disroot.org>
Date: Sun, 19 Sep 2021 23:21:47 +0200
Subject: [PATCH] some properties require non-empty layers
---
lib/Properties.hs | 119 ++++++++++++++++++++++++++++++----------------
lib/Tiled2.hs | 6 ++-
lib/Types.hs | 3 +-
lib/Util.hs | 10 +++-
4 files changed, 92 insertions(+), 46 deletions(-)
diff --git a/lib/Properties.hs b/lib/Properties.hs
index fe00857..405e984 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
@@ -7,12 +8,14 @@ module Properties (checkProperty) where
import Control.Monad (unless, when)
import Data.Text (Text, isPrefixOf)
-import Tiled2 (Layer (layerProperties), Property(..), PropertyValue(..))
-import Util (prettyprint)
+import Tiled2 (Layer (layerProperties), Property (..),
+ PropertyValue (..))
+import Util (layerIsEmpty, prettyprint)
import LintWriter (LintWriter, complain, dependsOn, forbid, info,
suggest, warn)
-import Types
+import Types (Dep (Link, Local, LocalMap, MapLink))
+
-- | the point of this module
@@ -26,74 +29,108 @@ import Types
--
-- I've attempted to build the LintWriter monad in a way
-- that should make this readable even to non-Haskellers
--- TODO: also pass the value of this property directly
checkProperty :: Layer -> Property -> LintWriter ()
checkProperty layer (Property name value) = case name of
- "jitsiRoom" -> strProp $ do
- info $ "found jitsi room: " <> prettyprint value
- suggestPropertyValue "jitsiTrigger" "onaction"
- "jitsiTrigger" -> strProp $ do
+ "jitsiRoom" -> do
+ uselessEmptyLayer
+ unwrapString $ \val -> do
+ info $ "found jitsi room: " <> prettyprint val
+ suggestPropertyValue "jitsiTrigger" "onaction"
+ "jitsiTrigger" -> do
+ isString
unless (hasProperty "jitsiTriggerMessage" layer)
$ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
requireProperty "jitsiRoom"
- "jitsiTriggerMessage" -> strProp
- $ requireProperty "jitsiTrigger"
+ "jitsiTriggerMessage" -> do
+ isString
+ requireProperty "jitsiTrigger"
"jitsiUrl" -> isForbidden
"jitsiConfig" -> isForbidden
"jitsiClientConfig" -> isForbidden
"jitsiRoomAdminTag" -> isForbidden
- "playAudio" -> linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ "playAudio" -> do
+ uselessEmptyLayer
+ unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
then Link link
else Local link
- "audioLoop" ->
- boolProp $ requireProperty "playAudio"
- "audioVolume" ->
- boolProp $ requireProperty "playAudio"
+ "audioLoop" -> do
+ isBool
+ requireProperty "playAudio"
+ "audioVolume" -> do
+ isBool
+ requireProperty "playAudio"
"openWebsite" -> do
+ uselessEmptyLayer
suggestPropertyValue "openWebsiteTrigger" "onaction"
- linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
- then Link link
- else Local link
- "openWebsiteTrigger" -> strProp $ do
+ unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ then Link link
+ else Local link
+ "openWebsiteTrigger" -> do
+ isString
unless (hasProperty "openWebsiteTriggerMessage" layer)
$ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\""
requireProperty "openWebsite"
- "openWebsiteTriggerMessage" ->
- strProp $ requireProperty "openWebsiteTrigger"
- "openWebsitePolicy" ->
- strProp $ requireProperty "openWebsite"
- "openTab" ->
- strProp $ requireProperty "openWebsite"
+ "openWebsiteTriggerMessage" -> do
+ isString
+ requireProperty "openWebsiteTrigger"
+ "openWebsitePolicy" -> do
+ isString
+ requireProperty "openWebsite"
+ "openTab" -> do
+ isString
+ requireProperty "openWebsite"
"url" -> isForbidden
"allowApi" -> isForbidden
- "exitUrl" -> linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+ "exitUrl" -> do
+ forbidEmptyLayer
+ unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
then MapLink link
else LocalMap link
- "startLayer" ->
- isForbidden
- "silent" -> boolProp $ pure ()
- -- could also make this a "hard error" (i.e. Left), but then it
- -- stops checking other properties as checkLayer short-circuits.
- _ -> warn $ "unknown property type " <> prettyprint name
+ "startLayer" -> do
+ forbidEmptyLayer
+ unwrapBool $ \case
+ True -> pure ()
+ False -> complain "startLayer must be set to true"
+ "silent" -> do
+ isBool
+ uselessEmptyLayer
+ _ ->
+ complain $ "unknown property type " <> prettyprint name
where
- strProp :: LintWriter () -> LintWriter ()
- strProp andthen = case value of
- StrProp _ -> andthen
+
+ -- | 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"
- linkProp f = case value of
+ -- | 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"
- boolProp f = case value of
- BoolProp _ -> f
+ -- | 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")
+ -- | 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")
+
-- | require some property in this layer
requireProperty name = unless (hasProperty name layer)
$ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
- -- | This property is forbidden and should not be used
- isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
- -- TODO: check if the property has the correct value
+ -- | 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
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index c3bf401..8220bfb 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -1,6 +1,6 @@
-{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- | This module provides Haskell types for Tiled's JSON exports, which you can
@@ -18,6 +18,7 @@ import Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import Data.Aeson.Types (Parser, typeMismatch)
import qualified Data.ByteString.Lazy.Char8 as C8
+import Data.Functor ((<&>))
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
@@ -25,13 +26,14 @@ import Data.Text (Text)
import Data.Vector (Vector)
import GHC.Exts (fromList, toList)
import GHC.Generics (Generic)
-import Data.Functor ((<&>))
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
+mkTiledId :: Int -> GlobalId
+mkTiledId i = GlobalId { unGlobalId = i }
-- | A locally indexed identifier.
newtype LocalId = LocalId { unLocalId :: Int }
diff --git a/lib/Types.hs b/lib/Types.hs
index d9c82b4..2b67d47 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -15,8 +15,9 @@ import Data.Text (Text)
import GHC.Generics (Generic)
import qualified Data.Aeson as A
+import Tiled2 (Property (Property),
+ PropertyValue (BoolProp, StrProp))
import Util (PrettyPrint (..), showText)
-import Tiled2 (Property(Property), PropertyValue (BoolProp, StrProp))
-- | Levels of errors and warnings, collectively called
diff --git a/lib/Util.hs b/lib/Util.hs
index 82d326f..5cf27e3 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -9,7 +9,7 @@ module Util where
import Data.Aeson as Aeson
import Data.Text (Text)
import qualified Data.Text as T
-import Tiled2 (PropertyValue(..))
+import Tiled2 (Layer (layerData), PropertyValue (..), mkTiledId)
-- | haskell's many string types are FUN …
showText :: Show a => a -> Text
@@ -32,7 +32,7 @@ instance PrettyPrint Aeson.Value where
instance PrettyPrint PropertyValue where
prettyprint = \case
- StrProp str -> str
+ StrProp str -> str
BoolProp bool -> if bool then "true" else "false"
-- | here since Unit is sometimes used as dummy type
@@ -41,3 +41,9 @@ instance PrettyPrint () where
printPretty :: PrettyPrint a => a -> IO ()
printPretty = putStr . T.unpack . prettyprint
+
+
+layerIsEmpty :: Layer -> Bool
+layerIsEmpty layer = case layerData layer of
+ Nothing -> True
+ Just d -> all ((==) $ mkTiledId 0) d
--
GitLab