diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/LintWriter.hs | 61 | ||||
| -rw-r--r-- | lib/Properties.hs | 116 | ||||
| -rw-r--r-- | lib/Tiled2.hs (renamed from src/Tiled2.hs) | 0 | ||||
| -rw-r--r-- | lib/Types.hs | 3 | ||||
| -rw-r--r-- | lib/Util.hs | 27 |
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 <> "\"" |