support for properties that aren't strings

apparently i couldn't read or something?

4 files changed, 88 insertions, 49 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
index ebd34bb..fe00857 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -5,15 +5,16 @@
 module Properties (checkProperty) where
 
 
-import           Control.Monad (unless)
+import           Control.Monad (unless, when)
 import           Data.Text     (Text, isPrefixOf)
-import           Tiled2        (Layer (layerProperties), Property, propertyName,
-                                propertyValue)
+import           Tiled2        (Layer (layerProperties), Property(..), PropertyValue(..))
 import           Util          (prettyprint)
 
 import           LintWriter    (LintWriter, complain, dependsOn, forbid, info,
                                 suggest, warn)
 import           Types
+
+
 -- | the point of this module
 --
 -- given a property, check if it is valid. It gets a reference
@@ -27,60 +28,75 @@ import           Types
 -- that should make this readable even to non-Haskellers
 -- TODO: also pass the value of this property directly
 checkProperty :: Layer -> Property -> LintWriter ()
-checkProperty layer prop = case propName of
-    "jitsiRoom" -> do
-      info $ "found jitsi room: " <> prettyprint (propertyValue prop)
+checkProperty layer (Property name value) = case name of
+    "jitsiRoom" -> strProp $ do
+      info $ "found jitsi room: " <> prettyprint value
       suggestPropertyValue "jitsiTrigger" "onaction"
-    "jitsiTrigger" ->
+    "jitsiTrigger" -> strProp $ do
+      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"
     "jitsiUrl" -> isForbidden
     "jitsiConfig" -> isForbidden
     "jitsiClientConfig" -> isForbidden
     "jitsiRoomAdminTag" -> isForbidden
-    "playAudio" ->
-      forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
-        then Link propValue
-        else Local propValue
+    "playAudio" -> linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+        then Link link
+        else Local link
     "audioLoop" ->
-      requireProperty "playAudio"
+      boolProp $ requireProperty "playAudio"
     "audioVolume" ->
-      requireProperty "playAudio"
+      boolProp $ requireProperty "playAudio"
     "openWebsite" -> do
       suggestPropertyValue "openWebsiteTrigger" "onaction"
-      if "http://" `isPrefixOf` propValue
-        then complain "cannot load content over http into map, please use https or include your assets locally"
-        else dependsOn $
-          if "https://" `isPrefixOf` propValue
-          then Link propValue
-          else Local propValue
-    "openWebsiteTrigger" ->
+      linkProp $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+          then Link link
+          else Local link
+    "openWebsiteTrigger" -> strProp $ do
+      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" ->
-      requireProperty "openWebsite"
-    "exitUrl" ->
-      forbidHTTPAndThen $ dependsOn $ if "https://" `isPrefixOf` propValue
-        then MapLink propValue
-        else LocalMap propValue
-    "startLayer" -> pure ()
+      strProp $ requireProperty "openWebsite"
+    "openTab" ->
+      strProp $ requireProperty "openWebsite"
+    "url" -> isForbidden
+    "allowApi" -> isForbidden
+    "exitUrl" -> linkProp $ \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 propName
+    _ -> warn $ "unknown property type " <> prettyprint name
     where
-      propName = propertyName prop
-      propValue = propertyValue prop
+      strProp :: LintWriter () -> LintWriter ()
+      strProp andthen = case value of
+        StrProp _ -> andthen
+        _ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
+      linkProp 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
+        _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
       -- | require some property in this layer
       requireProperty name = unless (hasProperty name layer)
-        $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint propName
+        $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
       -- | This property is forbidden and should not be used
-      isForbidden = forbid $ "property " <> prettyprint propName <> " should not be used"
+      isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
       -- TODO: check if the property has the correct value
       suggestPropertyValue :: Text -> Text -> LintWriter ()
       suggestPropertyValue name value = unless (hasProperty name layer)
         $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
-      forbidHTTPAndThen :: LintWriter () -> LintWriter ()
-      forbidHTTPAndThen andthen = if "http://" `isPrefixOf` propValue
-        then complain "cannot access content via http; either use https or include it locally instead."
-        else andthen
 
 
 
@@ -88,5 +104,5 @@ checkProperty layer prop = case propName of
 -- | does this layer have the given property?
 hasProperty :: Text -> Layer -> Bool
 hasProperty name = any
-  (\prop -> propertyName prop == name)
+  (\(Property name' _) -> name' == name)
   . layerProperties
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index c751cdc..c3bf401 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DeriveGeneric              #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE OverloadedStrings          #-}
@@ -24,6 +25,7 @@ import           Data.Text                  (Text)
 import           Data.Vector                (Vector)
 import           GHC.Exts                   (fromList, toList)
 import           GHC.Generics               (Generic)
+import Data.Functor ((<&>))
 
 
 -- | A globally indexed identifier.
@@ -67,28 +69,42 @@ parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a
 parseDefault o s d = fromMaybe d <$> o .:? s
 
 
--- | workadventure custom property
+{-- | workadventure custom property
 data Property = Property { propertyName  :: Text
                          --, propertyType :: Text (unnecessary since always string)
                          , propertyValue :: Text
                          } deriving (Eq, Generic, Show)
+-}
+
+data PropertyValue = StrProp Text | BoolProp Bool
+  deriving (Eq, Generic, Show)
+data Property = Property Text PropertyValue
+  deriving (Eq, Generic, Show)
+
 
 instance FromJSON Property where
   parseJSON (A.Object o) = do
-    propertyType <- o .: "type"
-    if propertyType /= A.String "string"
-      then typeMismatch "type" "string"
-      else do
-        propertyName <- o .: "name"
-        propertyValue <- o .: "value"
-        pure $ Property { propertyName, propertyValue }
+    name <- o .: "name"
+    o .: "type" >>= \case
+      A.String "string" -> do
+        val <- o .: "value"
+        pure $ Property name (StrProp val)
+      A.String "bool" -> do
+        val <- o .: "value"
+        pure $ Property name (BoolProp val)
+      ty -> fail $ "properties can only have type string or bool, but encountered " <> show ty
   parseJSON invalid = typeMismatch "Property" invalid
 
 instance ToJSON Property where
-  toJSON prop = object [ "type" .= A.String "string"
-                       , "name" .= propertyName prop
-                       , "value" .= propertyName prop
-                       ]
+  toJSON (Property name val) = case val of
+    StrProp str -> object [ "type" .= A.String "string"
+                          , "name" .= name
+                          , "value" .= str
+                          ]
+    BoolProp bool -> object [ "type" .= A.String "bool"
+                            , "name" .= name
+                            , "value" .= bool
+                            ]
 
 data Object = Object { objectId         :: Int
                        -- ^ Incremental id - unique across all objects
@@ -196,7 +212,7 @@ instance FromJSON Layer where
                                  <*>  o .: "y"
                                  <*> (o .: "data"       <|> pure Nothing)
                                  <*> o .:? "objects"
-                                 <*> (o .: "properties" <|> pure mempty)
+                                 <*> (o .:? "properties" <&> fromMaybe [])
                                  <*>  o .: "opacity"
                                  <*> (o .: "draworder"  <|> pure "topdown")
   parseJSON invalid = typeMismatch "Layer" invalid
diff --git a/lib/Types.hs b/lib/Types.hs
index 2e683c0..d9c82b4 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -16,6 +16,7 @@ import           GHC.Generics              (Generic)
 
 import qualified Data.Aeson                as A
 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 42ba960..82d326f 100644
--- a/lib/Util.hs
+++ b/lib/Util.hs
@@ -9,6 +9,7 @@ module Util where
 import           Data.Aeson as Aeson
 import           Data.Text  (Text)
 import qualified Data.Text  as T
+import Tiled2 (PropertyValue(..))
 
 -- | haskell's many string types are FUN …
 showText :: Show a => a -> Text
@@ -29,6 +30,11 @@ instance PrettyPrint Aeson.Value where
     Aeson.String s -> prettyprint s
     v              -> (T.pack . show) v
 
+instance PrettyPrint PropertyValue where
+  prettyprint = \case
+    StrProp str -> str
+    BoolProp bool -> if bool then "true" else "false"
+
 -- | here since Unit is sometimes used as dummy type
 instance PrettyPrint () where
   prettyprint _ = error "shouldn't pretty-print Unit"