1 files changed, 191 insertions, 0 deletions
diff --git a/src/Main.hs b/src/Main.hs
new file mode 100644
index 0000000..c5787db
--- /dev/null
+++ b/src/Main.hs
@@ -0,0 +1,191 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Main where
+
+import Data.Map (Map, (!?))
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import Data.Maybe (isJust, mapMaybe)
+import qualified Data.Aeson as Aeson
+import Data.Vector (Vector)
+import Data.Set (Set, fromList)
+import qualified Data.Vector as V
+import Control.Monad.Writer
+import Control.Monad.Trans.Maybe
+
+import Tiled2
+
+data Level = Warning | Suggestion | Info | Forbidden | Error
+  deriving Show
+
+data Hint = Hint
+  { hintLevel :: Level
+  , hintMsg :: Text }
+  deriving Show
+
+-- shorter constructors
+suggestion msg = Hint { hintLevel = Suggestion, hintMsg = msg }
+warning msg = Hint { hintLevel = Warning, hintMsg = msg }
+forbidden msg = Hint { hintLevel = Forbidden, hintMsg = msg }
+
+
+-- | 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 $ warning msg
+
+-- | get an attribute from a map
+getAttr :: Map Text Aeson.Value -> Text -> Either Hint Aeson.Value
+getAttr props name = unwrapWarn msg $ props !? name
+  where msg = "field " <> name <> "does not exist"
+
+-- | same as unwrapWarn, but for booleans
+assertWarn :: Text -> Bool -> Either Hint ()
+assertWarn msg cond = if cond then Right () else Left $ warning msg
+
+-- | 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
+
+-- | the given property should have the given value. Otherwise, warning.
+propEqual :: Map Text Aeson.Value -> Text -> Aeson.Value -> Either Hint ()
+propEqual props name value = do
+  value' <- getAttr props name
+  assertWarn ("field "<>name<>" has unexpected value "<>showAeson value'
+              <>", should be "<>showAeson value)
+    $ value' == value
+
+-- |
+-- This type may require some explanation.
+-- Essentially, it's a monad that can short-curcuit (i.e. abort),
+-- and also collect hints as it goes. Currently, both aborts and
+-- hints are the same type (Hint); if the monad ends up returning
+-- Left Hint, then something went entirely wrong; if it returns
+-- Right (a, [Hint]), then it ran through, calculated a, and collected
+-- a list of linter hints along the way.
+type MaybeWriter a = WriterT [Hint] (Either Hint) a
+
+
+-- | type juggling to get a single warning into MaybeWriter a
+maybeWriterHint :: (Text -> Hint) -> Text -> MaybeWriter ()
+maybeWriterHint constructor = tell . (: []) . constructor
+
+warn = maybeWriterHint warning
+info = maybeWriterHint (\t -> Hint { hintLevel = Info, hintMsg = t })
+forbid = maybeWriterHint forbidden
+suggest = maybeWriterHint suggestion
+complain = maybeWriterHint (\t -> Hint { hintLevel = Error, hintMsg = t })
+
+-- | adds quotes (but does not escape, for now!)
+quote :: Text -> Text
+quote text = "\"" <> text <> "\""
+
+-- | does this layer have the given property?
+hasProperty :: Text -> Layer -> Bool
+hasProperty name = any
+  (\prop -> prop !? "name" == Just (Aeson.String name))
+  . layerProperties
+
+
+
+-- | The main thing
+--
+-- 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
+checkProperty :: Layer -> Map Text Aeson.Value -> MaybeWriter ()
+checkProperty layer prop = do
+  tyObj <- lift $ getAttr prop "name"
+  ty <- lift $ case tyObj of
+    Aeson.String str -> Right str
+    _ -> Left (suggestion "wtf")
+  checkTyped ty
+  where checkTyped ty = case ty of
+          "jitsiRoom" -> do
+            lift $ propEqual prop "type" "string"
+            urlValue <- lift $ getAttr prop "value"
+            info $ "found jitsi room: " <> showAeson urlValue
+            suggestPropertyValue "jitsiTrigger" "onaction"
+            forbidProperty "jitsiUrl"
+            -- TODO: not sure if we should really disallow these entirely
+            forbidProperty "jitsiConfig"
+            forbidProperty "jitsiClientConfig"
+            forbidProperty "jitsiRoomAdminTag"
+          "jitsiTrigger" -> requireProperty "jitsiRoom"
+          "playAudio" -> do
+            -- TODO: check for url validity?
+            lift $ propEqual prop "type" "string"
+          "audioLoop" -> requireProperty "playAudio"
+          "audioVolume" -> requireProperty "playAudio"
+          "openWebsite" -> suggestPropertyValue "openWebsiteTrigger" "onaction"
+          "openWebsiteTrigger" -> requireProperty "openWebsite"
+          "openWebsitePolicy" -> requireProperty "openWebsite"
+          "exitUrl" -> return ()
+          "startLayer" -> return ()
+           -- 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"
+            -- TODO: check if the property has the correct value
+            suggestPropertyValue name value = unless (hasProperty name layer)
+              $ suggest $ "set property " <> quote name <> " to " <> quote value
+
+checkLayer :: Layer -> MaybeWriter ()
+checkLayer layer =
+  mapM_ (checkProperty layer) (layerProperties layer)
+
+-- TODO: possibly expand this to something more detailed?
+showContext :: Text -> Text
+showContext ctxt = " (in layer " <> ctxt <> ")\n"
+
+-- | pretty-printer for a result of WriterMaybe (currently only for errors/hints)
+showResult :: Show a => Text -> Either Hint (a, [Hint]) -> Maybe Text
+showResult ctxt (Left hint) = Just $ "ERROR: " <> hintMsg hint <> showContext ctxt
+showResult _ (Right (a, [])) = Nothing
+showResult ctxt (Right (a, hints)) = Just $ showHints hints
+  where
+    showHints hints = T.concat (mapMaybe showHint hints)
+    -- TODO: make the "log level" configurable
+    showHint Hint { hintMsg, hintLevel } = case hintLevel of
+      Info -> Nothing
+      _ -> Just $ showText hintLevel <> ": " <> hintMsg <> ctxtHint
+    ctxtHint = showContext ctxt
+
+
+
+main :: IO ()
+main = do
+  Right map <- loadTiledmap "example.json"
+  --print $ mapJitsiUrls map
+  --print $ fmap layerJitsiUrls (tiledmapLayers map)
+  -- TODO: print the layer each hint originates from
+  let lines = V.mapMaybe (\layer ->
+                            (showResult (T.pack $ layerName layer)
+                              . runWriterT
+                              . checkLayer)
+                            layer)
+              (tiledmapLayers map)
+  mapM_ T.putStr lines