lint general map properties

4 files changed, 121 insertions, 72 deletions

diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 9908fdd..08932b4 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -17,10 +17,12 @@ import qualified Data.Vector                as V
 import           GHC.Generics               (Generic)
 
 import           LintWriter                 (LintResult (..), LintWriter,
-                                             lintsToDeps)
-import           Properties                 (checkProperty)
+                                             lintsToDeps, resultToLints,
+                                             runLintWriter)
+import           Properties                 (checkLayerProperty,
+                                             checkMapProperty)
 import           Tiled2                     (Layer (layerName, layerProperties),
-                                             Tiledmap (tiledmapLayers),
+                                             Tiledmap (tiledmapLayers, tiledmapProperties),
                                              loadTiledmap)
 import           Types                      (Dep, Level (..), Lint (..), hint,
                                              lintLevel)
@@ -55,7 +57,7 @@ loadAndLintMap path = loadTiledmap path >>= pure . \case
 runLinter :: Tiledmap -> MapResult ()
 runLinter tiledmap = MapResult
   { mapresultLayer = Just layerMap
-  , mapresultGeneral = [] -- no general lints for now
+  , mapresultGeneral = propertyLints  -- no general lints for now
   , mapresultDepends = concatMap (lintsToDeps . snd) layer
   }
   where
@@ -64,10 +66,15 @@ runLinter tiledmap = MapResult
     layer = V.toList . V.map runCheck $ tiledmapLayers tiledmap
       where runCheck l = (layerName l, LintResult $ runWriterT (checkLayer l))
 
+    -- lints collected from properties
+    propertyLints = runLintWriter
+      $ mapM_ (checkMapProperty tiledmap) (tiledmapProperties tiledmap)
+
+
 -- | collect lints on a single map layer
 checkLayer :: Layer -> LintWriter ()
 checkLayer layer =
-  mapM_ (checkProperty layer) (layerProperties layer)
+  mapM_ (checkLayerProperty layer) (layerProperties layer)
 
 -- human-readable lint output, e.g. for consoles
 instance PrettyPrint a => PrettyPrint (MapResult a) where
@@ -79,7 +86,7 @@ instance PrettyPrint a => PrettyPrint (MapResult a) where
         (uncurry showResult)
         (maybe [] toList . mapresultLayer $ mapResult)
       prettyGeneral :: [Text]
-      prettyGeneral = prettyprint <$> mapresultGeneral mapResult
+      prettyGeneral = flip (<>) "\n" . prettyprint <$> mapresultGeneral mapResult
 
 
 -- TODO: possibly expand this to something more detailed?
diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 055e2d4..02815e3 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -9,7 +9,8 @@ module LintWriter where
 
 import           Control.Monad.Trans.Maybe ()
 import           Control.Monad.Writer      (MonadTrans (lift),
-                                            MonadWriter (tell), WriterT)
+                                            MonadWriter (tell), WriterT,
+                                            runWriterT)
 import           Data.Aeson                (ToJSON (toJSON))
 import           Data.Text                 (Text)
 
@@ -45,6 +46,16 @@ lintsToDeps (LintResult a) = case a of
   Left _             -> []
   Right (_, lints)   -> mapMaybe lintToDep lints
 
+-- | convert a lint result into a flat list of lints
+-- (throwing away information on if a single error was fatal)
+resultToLints :: LintResult a -> [Lint]
+resultToLints (LintResult res) = case res of
+  Left l           -> [l]
+  Right (_, lints) -> lints
+
+-- | Confusingly, this returns lints, not a …
+runLintWriter :: LintWriter a -> [Lint]
+runLintWriter = resultToLints . LintResult . runWriterT
 
 -- | write a hint into the LintWriter monad
 lint :: Level -> Text -> LintWriter ()
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 405e984..0805a4d 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -3,13 +3,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 
 -- | Contains checks for custom properties of the map json
-module Properties (checkProperty) where
+module Properties (checkLayerProperty, checkMapProperty) where
 
 
 import           Control.Monad (unless, when)
 import           Data.Text     (Text, isPrefixOf)
 import           Tiled2        (Layer (layerProperties), Property (..),
-                                PropertyValue (..))
+                                PropertyValue (..), Tiledmap)
 import           Util          (layerIsEmpty, prettyprint)
 
 import           LintWriter    (LintWriter, complain, dependsOn, forbid, info,
@@ -29,97 +29,80 @@ import           Types         (Dep (Link, Local, LocalMap, MapLink))
 --
 -- I've attempted to build the LintWriter monad in a way
 -- that should make this readable even to non-Haskellers
-checkProperty :: Layer -> Property -> LintWriter ()
-checkProperty layer (Property name value) = case name of
+checkLayerProperty :: Layer -> Property -> LintWriter ()
+checkLayerProperty layer p@(Property name value) = case name of
     "jitsiRoom" -> do
       uselessEmptyLayer
-      unwrapString $ \val -> do
+      unwrapString p $ \val -> do
         info $ "found jitsi room: " <> prettyprint val
-        suggestPropertyValue "jitsiTrigger" "onaction"
+        suggestProp $ Property "jitsiTrigger" (StrProp "onaction")
     "jitsiTrigger" -> do
-      isString
-      unless (hasProperty "jitsiTriggerMessage" layer)
+      isString p
+      unless (hasProperty "jitsiTriggerMessage")
        $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\""
-      requireProperty "jitsiRoom"
+      requireProp "jitsiRoom"
     "jitsiTriggerMessage" -> do
-      isString
-      requireProperty "jitsiTrigger"
+      isString p
+      requireProp "jitsiTrigger"
     "jitsiUrl" -> isForbidden
     "jitsiConfig" -> isForbidden
     "jitsiClientConfig" -> isForbidden
     "jitsiRoomAdminTag" -> isForbidden
     "playAudio" -> do
       uselessEmptyLayer
-      unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+      unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link
         then Link link
         else Local link
     "audioLoop" -> do
-      isBool
-      requireProperty "playAudio"
+      isBool p
+      requireProp "playAudio"
     "audioVolume" -> do
-      isBool
-      requireProperty "playAudio"
+      isBool p
+      requireProp "playAudio"
     "openWebsite" -> do
       uselessEmptyLayer
-      suggestPropertyValue "openWebsiteTrigger" "onaction"
-      unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+      suggestProp $ Property "openWebsiteTrigger" (StrProp "onaction")
+      unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link
         then Link link
         else Local link
     "openWebsiteTrigger" -> do
-      isString
-      unless (hasProperty "openWebsiteTriggerMessage" layer)
+      isString p
+      unless (hasProperty "openWebsiteTriggerMessage")
         $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the generic \"press SPACE to open Website\""
-      requireProperty "openWebsite"
+      requireProp "openWebsite"
     "openWebsiteTriggerMessage" -> do
-      isString
-      requireProperty "openWebsiteTrigger"
+      isString p
+      requireProp "openWebsiteTrigger"
     "openWebsitePolicy" -> do
-      isString
-      requireProperty "openWebsite"
+      isString p
+      requireProp "openWebsite"
     "openTab" -> do
-      isString
-      requireProperty "openWebsite"
+      isString p
+      requireProp "openWebsite"
     "url" -> isForbidden
     "allowApi" -> isForbidden
     "exitUrl" -> do
       forbidEmptyLayer
-      unwrapLink $ \link -> dependsOn $ if "https://" `isPrefixOf` link
+      unwrapLink p $ \link -> dependsOn $ if "https://" `isPrefixOf` link
         then MapLink link
         else LocalMap link
     "startLayer" -> do
       forbidEmptyLayer
-      unwrapBool $ \case
+      unwrapBool p $ \case
         True  -> pure ()
         False -> complain "startLayer must be set to true"
     "silent" -> do
-      isBool
+      isBool p
       uselessEmptyLayer
     _ ->
       complain $ "unknown property type " <> prettyprint name
     where
+      properties = layerProperties layer
+      hasProperty = containsProperty properties
+      isForbidden = forbidProperty name
+      requireProp = requireProperty properties
+      suggestProp = suggestPropertyValue properties
 
-      -- | asserts that this property is a string, and unwraps it
-      unwrapString f = case value of
-        StrProp str -> f str
-        _ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
-      -- | same as unwrapString, but also forbids http:// as prefix
-      unwrapLink f = case value of
-        StrProp str -> if "http://" `isPrefixOf` str
-          then complain "cannot access content via http; either use https or include it locally instead."
-          else f str
-        _ -> complain $ "type mismatch in property " <> name <> "; should be of typ string"
-      -- | asserts that this property is a boolean, and unwraps it
-      unwrapBool f = case value of
-        BoolProp b -> f b
-        _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
-      -- | just asserts that this is a string
-      isString = unwrapString (const $ pure ())
-      -- | just asserts  that this is a boolean
-      isBool = unwrapBool (const $ pure ())
-
-
-      -- | this property is forbidden and should not be used
-      isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
       -- | this property can only be used on a layer that contains at least one tiles
       forbidEmptyLayer = when (layerIsEmpty layer)
         $ complain ("property " <> name <> " should not be set on an empty layer")
@@ -127,19 +110,67 @@ checkProperty layer (Property name value) = case name of
       uselessEmptyLayer = when (layerIsEmpty layer)
         $ warn ("property" <> name <> " was set on an empty layer and is thereby useless")
 
-      -- | require some property in this layer
-      requireProperty name = unless (hasProperty name layer)
-        $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
-      -- | suggest a certain value for some other property in this layer
-      suggestPropertyValue :: Text -> Text -> LintWriter ()
-      suggestPropertyValue name value = unless (hasProperty name layer)
-        $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
+-- | Checks a single property of a map.
+--
+-- Doesn't really do all that much, but could in theory be expanded into a
+-- longer function same as checkLayerProperty.
+checkMapProperty :: Tiledmap -> Property -> LintWriter ()
+checkMapProperty map (Property name value) = case name of
+  "script" -> isForbidden
+  _        -> complain $ "unknown map property " <> name
+  where
+    -- | this property is forbidden and should not be used
+    isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
+
 
 
 
 
 -- | does this layer have the given property?
-hasProperty :: Text -> Layer -> Bool
-hasProperty name = any
-  (\(Property name' _) -> name' == name)
-  . layerProperties
+containsProperty :: [Property] -> Text -> Bool
+containsProperty props name = any
+  (\(Property name' _) -> name' == name) props
+
+-- | this property is forbidden and should not be used
+forbidProperty :: Text -> LintWriter ()
+forbidProperty name = forbid $ "property " <> prettyprint name <> " should not be used"
+
+
+-- | asserts that this property is a string, and unwraps it
+unwrapString :: Property -> (Text -> LintWriter ()) -> LintWriter ()
+unwrapString (Property name value) f = case value of
+  StrProp str -> f str
+  _ -> complain $ "type mismatch in property " <> name <> "; should be of type string"
+
+-- | same as unwrapString, but also forbids http:// as prefix
+unwrapLink :: Property -> (Text -> LintWriter ()) -> LintWriter ()
+unwrapLink (Property name value) f = case value of
+  StrProp str -> if "http://" `isPrefixOf` str
+    then complain "cannot access content via http; either use https or include it locally instead."
+    else f str
+  _ -> complain $ "type mismatch in property " <> name <> "; should be of typ string"
+
+-- | asserts that this property is a boolean, and unwraps it
+unwrapBool :: Property -> (Bool -> LintWriter ()) -> LintWriter ()
+unwrapBool (Property name value) f = case value of
+  BoolProp b -> f b
+  _ -> complain $ "type mismatch in property " <> name <> "; should be of type bool"
+
+-- | just asserts that this is a string
+isString :: Property -> LintWriter ()
+isString = flip unwrapString (const $ pure ())
+
+-- | just asserts that this is a boolean
+isBool :: Property -> LintWriter ()
+isBool = flip unwrapBool (const $ pure ())
+
+-- | require some property
+requireProperty :: [Property] -> Text -> LintWriter ()
+requireProperty props name = unless (containsProperty props name)
+  $ complain $ "property "<>prettyprint name<>" requires property "<>prettyprint name
+
+-- | suggest soem value for another property if that property does not
+-- also already exist
+suggestPropertyValue :: [Property] -> Property -> LintWriter ()
+suggestPropertyValue props (Property name value) = unless (containsProperty props name)
+  $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 8220bfb..79033f0 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -398,7 +398,7 @@ data Tiledmap = Tiledmap { tiledmapVersion         :: Float
                            -- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional)
                          , tiledmapRenderorder     :: String
                            -- ^ Rendering direction (orthogonal maps only)
-                         , tiledmapProperties      :: Map Text Text
+                         , tiledmapProperties      :: [Property]
                            -- ^ String key-value pairs
                          , tiledmapNextobjectid    :: Int
                            -- ^ Auto-increments for each placed object
@@ -416,7 +416,7 @@ instance FromJSON Tiledmap where
                                     <*>  o .: "tilesets"
                                     <*> (o .: "backgroundcolor" <|> pure Nothing)
                                     <*>  o .: "renderorder"
-                                    <*> (o .: "properties"      <|> pure mempty)
+                                    <*> (o .:? "properties" <&> fromMaybe [])
                                     <*>  o .: "nextobjectid"
   parseJSON invalid = typeMismatch "Tiledmap" invalid