From 33d2b0c5da01c48c8106876665e646e1d2f560e9 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sun, 19 Sep 2021 23:21:47 +0200 Subject: some properties require non-empty layers --- lib/Properties.hs | 119 +++++++++++++++++++++++++++++++++++------------------- 1 file changed, 78 insertions(+), 41 deletions(-) (limited to 'lib/Properties.hs') 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 -- cgit v1.2.3