type check properties

/finally/ figured out that all properties just look like {name, value,
type} so now that's abstracted away and Properties.hs doesn't look like
javascript anymore

3 files changed, 42 insertions, 56 deletions

diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 10c727d..09a2297 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -23,8 +23,8 @@ data Level = Warning | Suggestion | Info | Forbidden | Error | Fatal
 -- | a hint comes with an explanation (and a level)
 data Hint = Hint
   { hintLevel :: Level
-  , hintMsg   :: Text }
-  deriving (Generic, ToJSON)
+  , hintMsg   :: Text
+  } deriving (Generic, ToJSON)
 
 instance PrettyPrint Hint where
   prettyprint Hint { hintMsg, hintLevel } =
diff --git a/lib/Properties.hs b/lib/Properties.hs
index f4dff3d..f48d62e 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -6,25 +6,14 @@ module Properties (checkProperty) where
 
 
 import           Control.Monad             (unless)
-import           Control.Monad.Trans.Class (lift)
-import           Data.Aeson                as Aeson (Value (String))
-import           Data.Map                  (Map, (!?))
 import           Data.Text                 (Text)
-import           Tiled2                    (Layer (layerProperties))
+import           Tiled2                    (Layer (layerProperties), Property, propertyName, propertyValue)
 import           Util                      (prettyprint)
 
-import           LintWriter                (Hint, LintWriter, Level(..), hint,
-                                            assertWarn, complain, forbid, info,
-                                            suggest, unwrapWarn, warn)
+import           LintWriter                (LintWriter, complain, forbid, info,
+                                            suggest, warn, Dep(..), require)
 
--- | values may be anything, and are not typechecked (for now),
--- since they may contain arbitrary json – our only guarantee
--- is that they are named, and therefore a map.
-type Properties = Map Text Aeson.Value
-
-
-
--- | /technically/ the main function here
+-- | the point of this module
 --
 -- given a property, check if it is valid. It gets a reference
 -- to its own layer since sometimes the presense of one property
@@ -33,28 +22,13 @@ type Properties = Map Text Aeson.Value
 -- The tests in here are meant to comply with the informal spec
 -- at https://workadventu.re/map-building
 --
--- In practice, the actual specification of what is allowed is
--- handled in checkProperty', since apparently all possible layerProperties
--- are strings anyways, so this just extracts that string and then
--- calls that.
-checkProperty :: Layer -> Properties -> LintWriter ()
-checkProperty layer prop = do
-  tyObj <- lift $ getAttr prop "name"
-  ty <- lift $ case tyObj of
-    Aeson.String str -> Right str
-    _                -> Left (hint Suggestion "wtf")
-  checkProperty' layer prop ty
-
--- | The /real/ main  thing.
---
 -- I've attempted to build the LintWriter monad in a way
 -- that should make this readable even to non-Haskellers
-checkProperty' :: Layer -> Properties -> Text -> LintWriter ()
-checkProperty' layer prop ty = case ty of
+-- TODO: also pass the value of this property directly
+checkProperty :: Layer -> Property -> LintWriter ()
+checkProperty layer prop = case propName of
     "jitsiRoom" -> do
-      propEqual prop "type" "string"
-      urlValue <- lift $ getAttr prop "value"
-      info $ "found jitsi room: " <> prettyprint urlValue
+      info $ "found jitsi room: " <> prettyprint (propertyValue prop)
       suggestPropertyValue "jitsiTrigger" "onaction"
     "jitsiTrigger" ->
       requireProperty "jitsiRoom"
@@ -64,12 +38,12 @@ checkProperty' layer prop ty = case ty of
     "jitsiRoomAdminTag" -> isForbidden
     "playAudio" -> do
       -- TODO: check for url validity?
-      propEqual prop "type" "string"
+      pure ()
     "audioLoop" ->
       requireProperty "playAudio"
     "audioVolume" ->
       requireProperty "playAudio"
-    "openWebsite" ->
+    "openWebsite" -> do
       suggestPropertyValue "openWebsiteTrigger" "onaction"
     "openWebsiteTrigger" ->
       requireProperty "openWebsite"
@@ -79,13 +53,14 @@ checkProperty' layer prop ty = case ty of
     "startLayer" -> 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 ty
+    _ -> warn $ "unknown property type " <> prettyprint propName
     where
+      propName = propertyName prop
       -- | require some property in this layer
       requireProperty name = unless (hasProperty name layer)
-        $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint ty
+        $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint propName
       -- | This property is forbidden and should not be used
-      isForbidden = forbid $ "property " <> prettyprint ty <> " should not be used"
+      isForbidden = forbid $ "property " <> prettyprint propName <> " should not be used"
       -- TODO: check if the property has the correct value
       suggestPropertyValue :: Text -> Text -> LintWriter ()
       suggestPropertyValue name value = unless (hasProperty name layer)
@@ -97,18 +72,5 @@ checkProperty' layer prop ty = case ty of
 -- | does this layer have the given property?
 hasProperty :: Text -> Layer -> Bool
 hasProperty name = any
-  (\prop -> prop !? "name" == Just (Aeson.String name))
+  (\prop -> propertyName prop == name)
   . layerProperties
-
--- | get an attribute from a map
-getAttr :: Properties -> Text -> Either Hint Aeson.Value
-getAttr props name = unwrapWarn msg $ props !? name
-  where msg = "field " <> name <> "does not exist"
-
--- | lint goal: the property with the given name has given value
-propEqual :: Properties -> Text -> Aeson.Value -> LintWriter ()
-propEqual props name value = do
-  value' <- lift $ getAttr props name
-  assertWarn ("field "<>name<>" has unexpected value "<>prettyprint value'
-              <>", should be "<>prettyprint value)
-    $ value' == value
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index bc752a5..20886bd 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -8,6 +8,7 @@
 -- cover some of the types and records that are available in the format. For
 -- those you should read the TMX documentation at
 -- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/
+{-# LANGUAGE NamedFieldPuns #-}
 module Tiled2 where
 
 import           Control.Applicative        ((<|>))
@@ -66,6 +67,29 @@ parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a
 parseDefault o s d = fromMaybe d <$> o .:? s
 
 
+-- | workadventure custom property
+data Property = Property { propertyName :: Text
+                         --, propertyType :: Text (unnecessary since always string)
+                         , propertyValue :: Text
+                         } 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 }
+  parseJSON invalid = typeMismatch "Property" invalid
+
+instance ToJSON Property where
+  toJSON prop = object [ "type" .= A.String "string"
+                       , "name" .= propertyName prop
+                       , "value" .= propertyName prop
+                       ]
+
 data Object = Object { objectId         :: Int
                        -- ^ Incremental id - unique across all objects
                      , objectWidth      :: Double
@@ -154,7 +178,7 @@ data Layer = Layer { layerWidth      :: Double
                      -- ^ Array of GIDs. tilelayer only.
                    , layerObjects    :: Maybe (Vector Object)
                      -- ^ Array of Objects. objectgroup only.
-                   , layerProperties :: [Map Text Value]
+                   , layerProperties :: [Property]
                      -- ^ string key-value pairs.
                    , layerOpacity    :: Float
                      -- ^ Value between 0 and 1