lots of code reorganising and some deduplication

it was kinda getting messy in places.

Also found some accidental isomorphisms between types, so these are now
only one type because the consequences were getting silly.

1 files changed, 117 insertions, 92 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
index d65c9da..a9bf113 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -13,11 +13,10 @@ module Properties (checkMap, checkTileset, checkLayer) where
 import           Control.Monad (forM_, unless, when)
 import           Data.Text     (Text, isPrefixOf)
 import qualified Data.Vector   as V
-import           Tiled2        (HasName (getName),
-                                HasProperties (adjustProperties, getProperties),
-                                HasTypeName (typeName), IsProperty (asProperty),
-                                Layer (..), Object (..), Property (..),
+import           Tiled         (Layer (..), Object (..), Property (..),
                                 PropertyValue (..), Tiledmap (..), Tileset (..))
+import           TiledAbstract (HasName (..), HasProperties (..),
+                                HasTypeName (..), IsProperty (..))
 import           Util          (layerIsEmpty, mkProxy, naiveEscapeHTML,
                                 prettyprint, showText)
 
@@ -39,67 +38,59 @@ import           Uris          (SubstError (..), applySubst)
 
 -- | Checks an entire map for "general" lints.
 --
--- Note that it does /not/ call checkMapProperty; this is handled
--- seperately in CheckMap.hs, since these lints go into a different
--- field of the resulting json.
+-- Note that it does /not/ check any tile layer/tileset properties;
+-- these are handled seperately in CheckMap, since these lints go
+-- into a different field of the output.
 checkMap :: LintWriter Tiledmap
 checkMap = do
   tiledmap <- askContext
+  let unlessLayer = unlessElement (tiledmapLayers tiledmap)
 
-  -- test other things
-  mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap)
-
-  -- some layers should exist
-  hasLayerNamed "start" (const True)
-    "The map must have one layer named \"start\"."
-  hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType)
-    "The map must have one layer named \"floorLayer\" of type \"objectgroup\"."
-  hasLayer (flip containsProperty "exitUrl" . getProperties)
-    "The map must contain at least one layer with the property \"exitUrl\" set."
+  -- test custom map properties
+  mapM_ checkMapProperty (fromMaybe mempty $ tiledmapProperties tiledmap)
 
+  -- can't have these with the rest of layer/tileset lints since they're
+  -- not specific to any one of them
   refuseDoubledNames (tiledmapLayers tiledmap)
   refuseDoubledNames (tiledmapTilesets tiledmap)
 
+  -- some layers should exist
+  unlessElementNamed (tiledmapLayers tiledmap) "start"
+    $ complain "The map must have one layer named \"start\"."
+  unlessLayer (\l -> getName l == "floorLayer" && layerType l == "objectgroup")
+    $ complain "The map must have one layer named \"floorLayer\" of type \"objectgroup\"."
+  unlessLayer (flip containsProperty "exitUrl" . getProperties)
+    $ complain "The map must contain at least one layer with the property \"exitUrl\" set."
+
   -- reject maps not suitable for workadventure
   unless (tiledmapOrientation tiledmap == "orthogonal")
     $ complain "The map's orientation must be set to \"orthogonal\"."
   unless (tiledmapTileheight tiledmap == 32 && tiledmapTilewidth tiledmap == 32)
     $ complain "The map's tile size must be 32 by 32 pixels."
-  where
-    hasLayerNamed name p = hasLayer (\l -> layerName l == name && p l)
-    hasLayer p err = do
-      tiledmap <- askContext
-      unless (any p (tiledmapLayers tiledmap))
-        $ complain err
-
 
 -- | 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 :: Property -> LintWriter Tiledmap
-checkMapProperty p@(Property name _value) = case name of
+checkMapProperty p@(Property name _) = case name of
   "script" -> do
     -- this is kind of stupid, since if we also inject script this
     -- will be overriden anyways, but it also doesn't really hurt I guess
     -- TODO: perhaps include an explanation in the lint, or allow
     -- exactly that one value?
     lintConfig configAllowScripts >>= \case
-      False -> isForbidden
+      False -> forbid "cannot use property \"script\"; custom scripts are disallowed"
       True  -> pure ()
     lintConfig configScriptInject >>= \case
       Nothing  -> pure ()
       Just url -> setProperty "script" url
   "mapName" -> naiveEscapeProperty p
-  "mapLink" -> pure ()
-  "mapImage" -> pure ()
   "mapDescription" -> naiveEscapeProperty p
   "mapCopyright" -> naiveEscapeProperty p
-
+  "mapLink" -> pure ()
+  "mapImage" -> pure ()
   _        -> complain $ "unknown map property " <> prettyprint name
-  where
-    -- | this property is forbidden and should not be used
-    isForbidden = forbid $ "property " <> prettyprint name <> " should not be used"
 
 
 -- | check an embedded tile set.
@@ -126,24 +117,25 @@ checkTileset = do
   unlessHasProperty "copyright"
     $ forbid "property \"copyright\" is required for tilesets."
 
-
+  -- check individual tileset properties
   mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset)
-
-checkTilesetProperty :: Property -> LintWriter Tileset
-checkTilesetProperty p@(Property name _value) = case name of
-  "copyright" -> naiveEscapeProperty p
-  _           -> pure () -- are there any other properties?
+  where
+    checkTilesetProperty :: Property -> LintWriter Tileset
+    checkTilesetProperty p@(Property name _value) = case name of
+      "copyright" -> naiveEscapeProperty p
+      _           -> warn $ "unknown tileset property " <> prettyprint name
 
 
 -- | collect lints on a single map layer
 checkLayer :: LintWriter Layer
 checkLayer = do
   layer <- askContext
-  when (isJust (layerImage layer))
-    $ complain "imagelayer are not supported."
 
   refuseDoubledNames (getProperties  layer)
 
+  when (isJust (layerImage layer))
+    $ complain "imagelayer are not supported."
+
   case layerType layer of
     "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer)
     "group" -> pure ()
@@ -154,18 +146,24 @@ checkLayer = do
       adjust $ \l -> l { layerObjects = Nothing, layerProperties = Nothing }
 
       unless (layerName layer == "floorLayer") $ do
+
+        -- TODO: these two checks can probably be unified
         unlessHasProperty "getBadge"
-          $ warn "objectgrouop layer (which aren't the floor layer) are useless if not used to define badges."
-        when (null (layerObjects layer) || layerObjects layer == Just (V.fromList []))
-          $ warn "empty objectgroup layers (which aren't the floor layer) are useless."
+          $ warn "objectgrouop layer (which aren't the floor layer)\
+                 \are useless if not used to define badges."
+
+        when (null (layerObjects layer) || layerObjects layer == Just mempty)
+          $ warn "empty objectgroup layers (which aren't the floor\
+                 \layer) are useless."
 
       -- individual objects can't have properties
-      forM_ (fromMaybe (V.fromList []) $ layerObjects layer) $ \object ->
+      forM_ (fromMaybe mempty (layerObjects layer)) $ \object ->
         unless (null (objectProperties object))
-          $ warn "Properties cannot be set on individual objects. For setting badge tokens, use per-layer properties instead."
-      mapM_ checkObjectGroupProperty (getProperties layer)
-    ty -> --unless (layerName layer == "floorLayer" && ty == "objectgroup")
-          complain $ "unsupported layer type " <> prettyprint ty <> "."
+          $ warn "Properties cannot be set on individual objects. For setting\
+                 \badge tokens, use per-layer properties instead."
+
+      forM_ (getProperties layer) checkObjectGroupProperty
+    ty -> complain $ "unsupported layer type " <> prettyprint ty <> "."
 
   if layerType layer == "group"
     then when (null (layerLayers layer))
@@ -177,7 +175,7 @@ checkLayer = do
 -- | Checks a single (custom) property of an objectgroup layer
 checkObjectGroupProperty :: Property -> LintWriter Layer
 checkObjectGroupProperty p@(Property name _) = case name of
-  "getBadge" ->  -- TODO check if all objects of this layer are allowed, then collect them
+  "getBadge" ->
     unwrapString p $ \str ->
       unwrapBadgeToken str $ \token -> do
         layer <- askContext
@@ -195,10 +193,8 @@ checkObjectGroupProperty p@(Property name _) = case name of
             ObjectPolyline {} -> complain "cannot use polylines for badges."
   _ -> warn $ "unknown property " <> prettyprint name <> " for objectgroup layers"
 
+
 -- | Checks a single (custom) property of a "normal" tile layer
---
--- It gets a reference to its own layer since sometimes the presence
--- of one property implies the presence or absense of another.
 checkTileLayerProperty :: Property -> LintWriter Layer
 checkTileLayerProperty p@(Property name _value) = case name of
     "jitsiRoom" -> do
@@ -216,7 +212,8 @@ checkTileLayerProperty p@(Property name _value) = case name of
     "jitsiTrigger" -> do
       isString p
       unlessHasProperty "jitsiTriggerMessage"
-       $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter in jitsi meet room\"."
+       $ suggest "set \"jitsiTriggerMessage\" to a custom message to overwrite\
+                 \the default \"press SPACE to enter in jitsi meet room\"."
       requireProperty "jitsiRoom"
     "jitsiTriggerMessage" -> do
       isString p
@@ -245,9 +242,10 @@ checkTileLayerProperty p@(Property name _value) = case name of
       unwrapString p
         (setProperty "openWebsiteTrigger")
       unlessHasProperty "bbbTriggerMessage" $ do
-       suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the default \"press SPACE to enter the bbb room\""
        setProperty "openWebsiteTriggerMessage"
          ("press SPACE to enter bbb room" :: Text)
+       suggest "set \"bbbTriggerMessage\" to a custom message to overwrite the\
+               \default \"press SPACE to enter the bbb room\""
     "bbbTriggerMessage" -> do
       removeProperty "bbbTriggerMessage"
       requireProperty "bbbRoom"
@@ -274,9 +272,10 @@ checkTileLayerProperty p@(Property name _value) = case name of
         (dependsOn . Local)
     "openWebsiteTrigger" -> do
       isString p
-      unlessHasProperty "openWebsiteTriggerMessage"
-        $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to overwrite the default \"press SPACE to open Website\"."
       requireProperty "openWebsite"
+      unlessHasProperty "openWebsiteTriggerMessage"
+        $ suggest "set \"openWebsiteTriggerMessage\" to a custom message to\
+                  \overwrite the default \"press SPACE to open Website\"."
     "openWebsiteTriggerMessage" -> do
       isString p
       requireProperty "openWebsiteTrigger"
@@ -320,12 +319,13 @@ checkTileLayerProperty p@(Property name _value) = case name of
       deprecatedUseInstead instead =
         warn $ "property \"" <> name <> "\" is deprecated. Use \"" <> instead <> "\" instead."
 
-
-      -- | this property can only be used on a layer that contains at least one tiles
+      -- | this property can only be used on a layer that contains
+      -- | at least one tile
       forbidEmptyLayer = do
         layer <- askContext
         when (layerIsEmpty layer)
           $ complain ("property " <> prettyprint name <> " should not be set on an empty layer.")
+
       -- | this layer is allowed, but also useless on a layer that contains no tiles
       uselessEmptyLayer = do
         layer <- askContext
@@ -349,24 +349,45 @@ refuseDoubledNames things = foldr folding base things mempty
       where name = getName thing
     base _ = pure ()
 
---------- Helper functions & stuff ---------
+
+---- General functions ----
+
+unlessElement
+  :: Foldable f
+  => f a
+  -> (a -> Bool)
+  -> LintWriter b
+  -> LintWriter b
+unlessElement things op = unless (any op things)
+
+unlessElementNamed :: (HasName a, Foldable f)
+  => f a -> Text -> LintWriter b -> LintWriter b
+unlessElementNamed things name =
+  unlessElement things ((==) name . getName)
 
 unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a
-unlessHasProperty name andthen = do
-  layer <- askContext
-  let hasprop = any (\(Property name' _) -> name == name') (getProperties layer)
-  unless hasprop andthen
+unlessHasProperty name linter =
+  askContext >>= \ctxt ->
+    unlessElementNamed (getProperties ctxt) name linter
+
+-- | does this layer have the given property?
+containsProperty :: Foldable t => t Property -> Text -> Bool
+containsProperty props name = any
+  (\(Property name' _) -> name' == name) props
+
 
+----- Functions with concrete lint messages -----
 
 -- | this property is forbidden and should not be used
 forbidProperty :: Text -> LintWriter Layer
 forbidProperty name = do
-  forbid $ "property " <> prettyprint name <> " should not be used."
+  forbid $ "property " <> prettyprint name <> " is disallowed."
 
 propertyRequiredBy :: HasProperties a => Text -> Text -> LintWriter a
 propertyRequiredBy req by =
   unlessHasProperty req
-  $ complain $ "property "<>prettyprint req<>" is required by property "<> prettyprint by<>"."
+  $ complain $ "property " <> prettyprint req <>
+               " is required by property " <> prettyprint by <> "."
 
 -- | suggest some value for another property if that property does not
 -- also already exist
@@ -375,6 +396,11 @@ suggestProperty (Property name value) =
   unlessHasProperty name
   $ suggest $ "set property " <> prettyprint name <> " to " <> prettyprint value<>"."
 
+
+
+---- Functions for adjusting the context -----
+
+
 -- | set a property, overwriting whatever value it had previously
 setProperty :: (IsProperty prop, HasProperties ctxt)
   => Text -> prop -> LintWriter ctxt
@@ -388,37 +414,41 @@ removeProperty name = adjust $ \ctxt ->
   flip adjustProperties ctxt
   $ \ps -> Just $ filter (\(Property name' _) -> name' /= name) ps
 
+naiveEscapeProperty :: HasProperties a =>  Property -> LintWriter a
+naiveEscapeProperty prop@(Property name _) =
+  unwrapString prop (setProperty name . naiveEscapeHTML)
 
--- | does this layer have the given property?
-containsProperty :: Foldable t => t Property -> Text -> Bool
-containsProperty props name = any
-  (\(Property name' _) -> name' == name) props
-
+---- "unwrappers" checking that a property has some type, then do something ----
 
 -- | asserts that this property is a string, and unwraps it
 unwrapString :: Property -> (Text -> LintWriter a) -> LintWriter a
 unwrapString (Property name value) f = case value of
   StrProp str -> f str
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string."
+  _ -> complain $ "type error: property "
+               <> prettyprint name <> " should be of type string."
 
 -- | same as unwrapString, but also forbids http:// as prefix
 unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a
 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."
+    then complain "cannot access content via http; either use https or include\
+                  \it locally in your repository instead."
     else f str
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string and contain a valid uri."
+  _ -> complain $ "type error: property " <> prettyprint name <> " should be\
+                  \of type string and contain a valid uri."
 
 -- | asserts that this property is a boolean, and unwraps it
 unwrapBool :: Property -> (Bool -> LintWriter a) -> LintWriter a
 unwrapBool (Property name value) f = case value of
   BoolProp b -> f b
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type bool."
+  _ -> complain $ "type error: property " <> prettyprint name
+               <> " should be of type bool."
 
 unwrapInt :: Property -> (Int -> LintWriter a) -> LintWriter a
 unwrapInt (Property name value) f = case value of
   IntProp float -> f float
-  _ -> complain $ "type error: property " <> prettyprint name <> " should be of type int."
+  _ -> complain $ "type error: property " <> prettyprint name
+               <> " should be of type int."
 
 unwrapPath :: Text -> (RelPath -> LintWriter a) -> LintWriter a
 unwrapPath str f = case parsePath str of
@@ -437,20 +467,6 @@ unwrapBadgeToken str f = case parseToken str of
   Just a  -> f a
   Nothing -> complain "invalid badge token."
 
--- | just asserts that this is a string
-isString :: Property -> LintWriter a
-isString = flip unwrapString (const $ pure ())
-
--- | just asserts that this is a boolean
-isBool :: Property -> LintWriter a
-isBool = flip unwrapBool (const $ pure ())
-
-isIntInRange :: Int -> Int -> Property -> LintWriter a
-isIntInRange l r p@(Property name _) = unwrapInt p $ \int ->
-  if l < int && int < r then pure ()
-  else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"."
-
-
 unwrapURI :: (KnownSymbol s, HasProperties a)
   => Proxy s -> Property -> (Text -> LintWriter a) -> (RelPath -> LintWriter a) -> LintWriter a
 unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
@@ -468,6 +484,15 @@ unwrapURI sym p@(Property name _) f g = unwrapLink p $ \link -> do
       WrongScope schema ->
         "the URI schema " <> schema <> ":// cannot be used on \""<>name<>"\"."
 
-naiveEscapeProperty :: HasProperties a =>  Property -> LintWriter a
-naiveEscapeProperty prop@(Property name _) =
-  unwrapString prop (setProperty name . naiveEscapeHTML)
+-- | just asserts that this is a string
+isString :: Property -> LintWriter a
+isString = flip unwrapString (const $ pure ())
+
+-- | just asserts that this is a boolean
+isBool :: Property -> LintWriter a
+isBool = flip unwrapBool (const $ pure ())
+
+isIntInRange :: Int -> Int -> Property -> LintWriter a
+isIntInRange l r p@(Property name _) = unwrapInt p $ \int ->
+  if l < int && int < r then pure ()
+  else complain $ "Property " <> prettyprint name <> " should be between" <> showText l <> " and " <> showText r<>"."