diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/LintWriter.hs | 4 | ||||
| -rw-r--r-- | lib/Properties.hs | 68 | ||||
| -rw-r--r-- | lib/Tiled2.hs | 26 |
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 |