shorten Properties.hs

down almost 100 lines of code!

(and hopefully denotationally equivalent, except for the bits about
where it was wrong before and didn't replace uris correctly)

1 files changed, 76 insertions, 152 deletions

diff --git a/lib/Properties.hs b/lib/Properties.hs
index 62cb4f7..6f53c48 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -10,7 +10,7 @@
 module Properties (checkMap, checkTileset, checkLayer) where
 
 
-import           Control.Monad (forM_, unless, when)
+import           Control.Monad (forM_, unless, when, forM)
 import           Data.Text     (Text, intercalate, isPrefixOf)
 import qualified Data.Text     as T
 import qualified Data.Vector   as V
@@ -26,7 +26,6 @@ import           Badges        (Badge (Badge),
                                 BadgeArea (BadgePoint, BadgeRect), BadgeToken,
                                 parseToken)
 import           Data.Data     (Proxy (Proxy))
-import           Data.Functor  ((<&>))
 import           Data.List     ((\\))
 import           Data.Maybe    (fromMaybe, isJust)
 import           Data.Set      (Set)
@@ -36,7 +35,7 @@ import           LayerData     (Collision, layerOverlaps)
 import           LintConfig    (LintConfig (..))
 import           LintWriter    (LintWriter, adjust, askContext, askFileDepth,
                                 complain, dependsOn, forbid, lintConfig,
-                                offersBadge, offersEntrypoint, suggest, warn)
+                                offersBadge, offersEntrypoint, suggest, warn, zoom)
 import           Paths         (PathResult (..), RelPath (..), getExtension,
                                 isOldStyle, parsePath)
 import           Types         (Dep (Link, Local, LocalMap, MapLink))
@@ -197,18 +196,20 @@ checkLayer = do
     "group" -> pure ()
     "objectgroup" -> do
 
+
+      -- check object properties
+      objs <- forM (layerObjects layer) $ mapM $ \object -> do
+        -- this is a confusing constant zoom ...
+        zoom (const layer) (const object) $ mapM_ checkObjectProperty (getProperties object)
+      adjust (\l -> l { layerObjects = objs })
+
       -- all objects which don't define badges
-      publicObjects <- askContext <&>
-        fmap (V.filter (not . (`containsProperty` "getBadge"))) . layerObjects
+      let publicObjects = fmap (V.filter (not . (`containsProperty` "getBadge"))) objs
 
       -- remove badges from output
       adjust $ \l -> l { layerObjects = publicObjects
                        , layerProperties = Nothing }
 
-      -- check object properties
-      forM_ (fromMaybe mempty (layerObjects layer)) $ \object -> do
-        mapM_ (checkObjectProperty object) (getProperties object)
-
       -- check layer properties
       forM_ (getProperties layer) checkObjectGroupProperty
 
@@ -225,15 +226,14 @@ checkLayer = do
     else when (isJust (layerLayers layer))
     $ complain "Layer is not of type \"group\", but has sublayers."
 
-checkObjectProperty :: Object -> Property -> LintWriter Layer
-checkObjectProperty obj p@(Property name _) = case name of
+checkObjectProperty :: Property -> LintWriter Object
+checkObjectProperty p@(Property name _) = do
+ obj <- askContext
+ case name of
   "url" -> do
-    unwrapURI' (Proxy @"website") p
+    unwrapURI (Proxy @"website") p
       (dependsOn . Link)
       (const $ forbid "using \"url\" to open local html files is disallowed.")
-
-    -- | TODO: The uri should be rewritten if the unwrapURI' did add the wrapper
-
     unless (objectType obj == "website")
       $ complain "\"url\" can only be set for objects of type \"website\""
   "allowApi" -> forbidProperty name
@@ -255,79 +255,40 @@ checkObjectProperty obj p@(Property name _) = case name of
               (Just w, Just h) | w /= 0 && h /= 0 ->
                  BadgeRect objectX objectY w h
               _ -> BadgePoint objectX objectY
-
-  -- | these properties are used by the extended script to allow doors
-  "door" -> do
-    isBool p
-    unless (objectType obj == "variable") $
-      complain "the \"door\" property should only be set on objects of type \"variable\""
-    when (null (objectName obj) || objectName obj == Just mempty) $
-      complain "Door variables objects must have a name given"
-
-  "default" -> do
-    isBool p
-    suggestProperty "door"
-  "persist" -> do
-    isBool p
-    suggestProperty "door"
-  "openLayer" -> do
-    isString p
-    suggestProperty "door"
-  "closeLayer" -> do
-    isString p
-    suggestProperty "door"
-  "openSound" -> do
-    isString p
-
-    unwrapURI' (Proxy @"audio") p
-      (dependsOn . Link)
-      (dependsOn . Local)
-
-    unless (containsProperty obj "soundRadius") $
-      suggest "set \"soundRadius\" to a limit the door sound to a certain area\"."
-
-    suggestProperty "door"
-  "closeSound" -> do
-    isString p
-
-    unwrapURI' (Proxy @"audio") p
-      (dependsOn . Link)
-      (dependsOn . Local)
-
-    unless (containsProperty obj "soundRadius") $
-      -- Do not suggest again if already suggested for openSound
-      unless (containsProperty obj "openSound") $
-        suggest "set \"soundRadius\" to a limit the door sound to a certain area\"."
-
-    suggestProperty "door"
-
-  -- | these properties are used by the extended script to allow doors
-  "bell" -> do
-    isBool p
-    unless (objectType obj == "variable") $
-      complain "the \"bell\" property should only be set on objects of type \"variable\""
-    when (null (objectName obj) || objectName obj == Just mempty) $
-      complain "Bell variables objects must have a name given"
-  "bellSound" -> do
-    isString p
-
-    unwrapURI' (Proxy @"audio") p
-      (dependsOn . Link)
-      (dependsOn . Local)
-
-    suggestProperty "bell"
-
-  -- | Applies to doors and bells as well
   "soundRadius" -> do
-    isInt p
-    -- | maybe we should lint that this property is only used on door and bell variables
-
-
-  _ -> warn $ "unknown object property " <> prettyprint name <> "."
-  where
-    suggestProperty req = do
-      unless (containsProperty obj req) $
-        suggest( "property " <> prettyprint req <> " is suggested for property " <> prettyprint name <> ".")
+    isIntInRange 0 maxBound p
+    unless (containsProperty obj "door" || containsProperty obj "bell")
+      $ complain "property \"soundRadius\" can only be set on objects with \
+                 \either property \"bell\" or \"door\" also set."
+
+  _ | name `elem` [ "default", "persist", "openLayer", "closeLayer" ] -> do
+        isBool p
+        suggestPropertyName' "door"
+    -- extended API for doors and bells
+    | name `elem` ["door", "bell"] -> do
+        isBool p
+        unless (objectType obj == "variable") $
+          complain $ "the "<>prettyprint name<>" property should only be set \
+                     \on objects of type \"variable\""
+        when (null (objectName obj) || objectName obj == Just mempty) $
+          complain $ "Objects with the property "<>prettyprint name<>" set must \
+                     \be named."
+    | name `elem` [ "openSound", "closeSound", "bellSound" ] -> do
+        isString p
+        unwrapURI (Proxy @"audio") p
+          (dependsOn . Link)
+          (dependsOn . Local)
+        case name of
+          "bellSound" ->
+            suggestPropertyName' "bell"
+          "closeSound" | containsProperty obj  "openSound" ->
+            suggestPropertyName' "door"
+          _ -> do
+            suggestPropertyName' "door"
+            suggestPropertyName "soundRadius"
+              "set \"soundRadius\" to limit the door sound to a certain area."
+    | otherwise ->
+        warn $ "unknown object property " <> prettyprint name <> "."
 
 -- | Checks a single (custom) property of an objectgroup layer
 checkObjectGroupProperty :: Property -> LintWriter Layer
@@ -472,56 +433,22 @@ checkTileLayerProperty p@(Property name _value) = case name of
     "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \
                            \ layer; it does not work on tile layers."
 
-    -- | these properties are used by the extended script to allow doors
+    -- extended API stuff
     "zone" -> do
       isString p
       uselessEmptyLayer
-    "doorVariable" -> do
-      isString p
-      requireProperty "zone"
-    "autoOpen" -> do
-      isBool p
-      requireProperty "doorVariable"
-    "autoClose" -> do
-      isBool p
-      requireProperty "doorVariable"
-    "code" -> do
-      isString p
-      requireProperty "doorVariable"
-    "openTriggerMessage" -> do
-      isString p
-      requireProperty "doorVariable"
-    "closeTriggerMessage" -> do
-      isString p
-      requireProperty "doorVariable"
-
-    -- | these properties are used by the extended script to allow bells
-
-    "bellVariable" -> do
-      isString p
-      requireProperty "zone"
-    "bellButtonText" -> do
-      isString p
-      requireProperty "bellVariable"
-    "bellPopup" -> do
-      isString p
-      requireProperty "bellVariable"
-
-    -- | these properties are used by the extended script to allow action zones¶
-    "bindVariable" -> do
-      isString p
-      requireProperty "zone"
-    "enterValue" -> do
-      isString p
-      requireProperty "bindVariable"
-    "leaveValue" -> do
-      isString p
-      requireProperty "bindVariable"
-
-
     -- name on tile layer unsupported
     "name" -> isUnsupported
-    _ ->
+    _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ]
+        -> do { isString p; requireProperty "zone" }
+      | name `elem` [ "autoOpen", "autoClose", "code"
+                    , "openTriggerMessage", "closeTriggerMessage"]
+        -> do { isString p; requireProperty "doorVariable" }
+      | name `elem` [ "bellButtonText", "bellPopup" ]
+        -> do { isString p; requireProperty "bellVariable" }
+      | name `elem` [ "enterValue", "leaveValue" ]
+        -> do { isString p; requireProperty "bindVariable" }
+      | otherwise ->
         warn $ "unknown property type " <> prettyprint name
     where
       isForbidden = forbidProperty name
@@ -613,7 +540,7 @@ whenLayerCollisions layers f andthen = do
 ----- Functions with concrete lint messages -----
 
 -- | this property is forbidden and should not be used
-forbidProperty :: Text -> LintWriter Layer
+forbidProperty :: HasProperties a => Text -> LintWriter a
 forbidProperty name = do
   forbid $ "property " <> prettyprint name <> " is disallowed."
 
@@ -625,12 +552,21 @@ propertyRequiredBy req by =
 
 -- | suggest some value for another property if that property does not
 -- also already exist
-suggestProperty :: Property -> LintWriter Layer
-suggestProperty (Property name value) =
-  unlessHasProperty name
-  $ suggest $ "set property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"."
+suggestProperty :: HasProperties a => Property -> LintWriter a
+suggestProperty p@(Property name value) =
+  suggestProperty' p $ "set property " <> prettyprint name <> " to \"" <> prettyprint value<>"\"."
+
+suggestProperty' :: HasProperties a => Property -> Text -> LintWriter a
+suggestProperty' (Property name _) msg =
+  unlessHasProperty name (suggest msg)
 
+suggestPropertyName :: HasProperties a => Text -> Text -> LintWriter a
+suggestPropertyName name msg =
+  unlessHasProperty name (suggest msg)
 
+suggestPropertyName' :: HasProperties a => Text -> LintWriter a
+suggestPropertyName' name = suggestPropertyName name
+  $ "consider setting property " <> prettyprint name <> "."
 
 ---- Functions for adjusting the context -----
 
@@ -701,16 +637,17 @@ unwrapBadgeToken str f = case parseToken str of
 
 
 -- | unwraps a URI
-unwrapURI' :: (KnownSymbol s)
+unwrapURI :: (KnownSymbol s, HasProperties a)
   => Proxy s
   -> Property
   -> (Text -> LintWriter a)
   -> (RelPath -> LintWriter a)
   -> LintWriter a
-unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do
+unwrapURI sym p@(Property name _) f g = unwrapString p $ \link -> do
   subst <- lintConfig configUriSchemas
   case applySubst sym subst link of
     Right uri -> do
+      setProperty name uri
       f uri
     Left NotALink -> unwrapPath link g
     Left err -> complain $ case err of
@@ -726,15 +663,6 @@ unwrapURI' sym p@(Property name _) f g = unwrapString p $ \link -> do
         <> intercalate ", " (fmap (<> "://") allowed) <> "."
       VarsDisallowed -> "extended API links are disallowed in links"
 
--- | unwraps a URI and adjusts the linter's output
-unwrapURI :: (KnownSymbol s, HasProperties a)
-  => Proxy s
-  -> Property
-  -> (Text -> LintWriter a)
-  -> (RelPath -> LintWriter a)
-  -> LintWriter a
-unwrapURI sym p@(Property name _) f =
-  unwrapURI' sym p $ \uri -> setProperty name uri >> f uri
 
 
 -- | just asserts that this is a string
@@ -745,10 +673,6 @@ isString = flip unwrapString (const $ pure ())
 isBool :: Property -> LintWriter a
 isBool = flip unwrapBool (const $ pure ())
 
--- | just asserts that this is a int
-isInt:: Property -> LintWriter a
-isInt = flip unwrapInt (const $ pure ())
-
 isIntInRange :: Int -> Int -> Property -> LintWriter b
 isIntInRange = isOrdInRange @Int unwrapInt