some properties require non-empty layers

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