moving lots of code around

(also renaming things now that concepts seem a bit clearer)

5 files changed, 207 insertions, 0 deletions

diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
new file mode 100644
index 0000000..0146366
--- /dev/null
+++ b/lib/LintWriter.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- | a monad that collects warnings, outputs, etc,
+module LintWriter where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Maybe (isJust, mapMaybe)
+import Control.Monad.Writer
+import Control.Monad.Trans.Maybe
+
+
+-- | Levels of errors and warnings, collectively called
+-- "Hints" until I can think of some better name
+data Level = Warning | Suggestion | Info | Forbidden | Error
+  deriving Show
+
+-- | a hint comes with an explanation (and a level)
+data Hint = Hint
+  { hintLevel :: Level
+  , hintMsg :: Text }
+  deriving Show
+
+-- shorter constructor
+hint level msg = Hint { hintLevel = level, hintMsg = msg }
+
+-- | a monad to collect hints. If it yields Left, then the
+-- map is flawed in some fundamental way which prevented us
+-- from getting any hints at all except whatever broke it
+type LintWriter a = WriterT [Hint] (Either Hint) a
+
+type LintResult a = Either Hint (a, [Hint])
+
+-- | write a hint into the LintWriter monad
+lint :: Level -> Text -> LintWriter ()
+lint level = tell . (: []) . hint level
+
+warn = lint Warning
+info = lint Info
+forbid = lint Forbidden
+suggest = lint Suggestion
+complain = lint Error
+
+
+-- TODO: all these functions should probably also just operate on LintWriter
+
+-- | converts a Maybe to an Either, with a default value for Left
+unwrap :: b -> Maybe a  -> Either b a
+unwrap hint maybe = case maybe of
+  Just a -> Right a
+  Nothing -> Left hint
+
+-- | unwrap and produce a warning if the value was Nothing
+unwrapWarn :: Text -> Maybe a -> Either Hint a
+unwrapWarn msg = unwrap $ hint Warning msg
+
+-- | same as unwrapWarn, but for booleans
+assertWarn :: Text -> Bool -> LintWriter ()
+assertWarn msg cond = lift $ if cond then Right () else Left $ hint Warning msg
diff --git a/lib/Properties.hs b/lib/Properties.hs
new file mode 100644
index 0000000..0b9a71f
--- /dev/null
+++ b/lib/Properties.hs
@@ -0,0 +1,116 @@
+{-# LANGUAGE NamedFieldPuns    #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Contains checks for custom properties of the map json
+module Properties (checkProperty) where
+
+
+import           Control.Monad             (unless, when)
+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           Util                      (quote, showAeson)
+
+import           LintWriter                (Hint, LintWriter, Level(..), hint,
+                                            assertWarn, complain, forbid, info,
+                                            suggest, unwrapWarn, warn)
+
+-- | 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
+--
+-- given a property, check if it is valid. It gets a reference
+-- to its own layer since sometimes the presense of one property
+-- implies the presence or absense of another.
+--
+-- The tests in here are meant to comply with the informal spec
+-- at https://workadventu.re/map-building
+--
+-- In practice, the actual specifiaction 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
+    "jitsiRoom" -> do
+      propEqual prop "type" "string"
+      urlValue <- lift $ getAttr prop "value"
+      info $ "found jitsi room: " <> showAeson urlValue
+      suggestPropertyValue "jitsiTrigger" "onaction"
+    "jitsiTrigger" ->
+      requireProperty "jitsiRoom"
+    "jitsiUrl" -> isForbidden
+    "jitsiConfig" -> isForbidden
+    "jitsiClientConfig" -> isForbidden
+    "jitsiRoomAdminTag" -> isForbidden
+    "playAudio" -> do
+      -- TODO: check for url validity?
+      propEqual prop "type" "string"
+    "audioLoop" ->
+      requireProperty "playAudio"
+    "audioVolume" ->
+      requireProperty "playAudio"
+    "openWebsite" ->
+      suggestPropertyValue "openWebsiteTrigger" "onaction"
+    "openWebsiteTrigger" ->
+      requireProperty "openWebsite"
+    "openWebsitePolicy" ->
+      requireProperty "openWebsite"
+    "exitUrl" -> pure ()
+    "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 " <> quote ty
+    where
+      -- | require some property in this layer
+      requireProperty name = unless (hasProperty name layer)
+        $ complain $ "property "<>quote name<>" requires property "<>quote ty
+      -- | forbid some property in this layer
+      forbidProperty name = when (hasProperty name layer)
+        $ forbid $ "property " <> quote name <> " should not be used"
+      -- | This property is forbidden and should not be used
+      isForbidden = forbid $ "property " <> quote ty <> " should not be used"
+      -- TODO: check if the property has the correct value
+      suggestPropertyValue name value = unless (hasProperty name layer)
+        $ suggest $ "set property " <> quote name <> " to " <> quote value
+
+
+
+
+-- | does this layer have the given property?
+hasProperty :: Text -> Layer -> Bool
+hasProperty name = any
+  (\prop -> prop !? "name" == Just (Aeson.String 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 "<>showAeson value'
+              <>", should be "<>showAeson value)
+    $ value' == value
diff --git a/src/Tiled2.hs b/lib/Tiled2.hs
index 17b2b77..17b2b77 100644
--- a/src/Tiled2.hs
+++ b/lib/Tiled2.hs
diff --git a/lib/Types.hs b/lib/Types.hs
new file mode 100644
index 0000000..082b30e
--- /dev/null
+++ b/lib/Types.hs
@@ -0,0 +1,3 @@
+-- | basic types for workadventure maps
+
+module Types where
diff --git a/lib/Util.hs b/lib/Util.hs
new file mode 100644
index 0000000..be67143
--- /dev/null
+++ b/lib/Util.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module Util where
+
+import Data.Text (Text)
+import Data.Text as T
+import Data.Aeson as Aeson
+
+-- | haskell's many string types are FUN …
+showText :: Show a => a -> Text
+showText = T.pack . show
+
+-- | same as showText, but without the "String"-prefix for strings
+-- TODO: serialise back into json for printing? People may get
+-- confused by the type annotations if they only know json …
+showAeson :: Aeson.Value -> Text
+showAeson (Aeson.String s) = showText s
+showAeson v = showText v
+
+
+
+
+
+-- | adds quotes (but does not escape, for now!)
+quote :: Text -> Text
+quote text = "\"" <> text <> "\""