Merge branch 'extended-scripts' into 'main'

Extended scripts support

See merge request hub/walint!1

2 files changed, 113 insertions, 35 deletions

diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs
index 74df70a..bc2decf 100644
--- a/lib/LintWriter.hs
+++ b/lib/LintWriter.hs
@@ -16,6 +16,7 @@ module LintWriter
   , LintWriter'
   , LintResult
   , invertLintResult
+  , zoom
   -- * working with lint results
   , resultToDeps
   , resultToOffers
@@ -43,9 +44,9 @@ module LintWriter
 import           Data.Text                  (Text)
 
 import           Badges                     (Badge)
-import           Control.Monad.State        (StateT, modify)
+import           Control.Monad.State        (StateT, modify, MonadState (put))
 import           Control.Monad.Trans.Reader (Reader, asks, runReader)
-import           Control.Monad.Trans.State  (runStateT)
+import           Control.Monad.Trans.State  (runStateT, get)
 import           Control.Monad.Writer.Lazy  (lift)
 import           Data.Bifunctor             (Bifunctor (second))
 import           Data.Map                   (Map, fromListWith)
@@ -86,6 +87,22 @@ runLintWriter config context depth linter = LinterState
   $ (depth, context, config)
   where runstate = runStateT linter (LinterState ([], context))
 
+
+zoom :: (a -> b) -> (b -> a) -> LintWriter a -> LintWriter' b a
+zoom embed extract operation = do
+  config <- lintConfig id
+  depth <- askFileDepth
+  let result ctxt = runLintWriter config ctxt depth operation
+  LinterState (lints,a) <- get
+  let res = result . extract $ a
+  put $ LinterState
+    . (resultToLints res <> lints,)
+    . embed
+    . resultToAdjusted
+    $ res
+  pure $ resultToAdjusted res
+
+
 -- | "invert" a linter's result, grouping lints by their messages
 invertLintResult :: HasName ctxt => LintResult ctxt -> Map Hint [ctxt]
 invertLintResult (LinterState (lints, ctxt)) =
diff --git a/lib/Properties.hs b/lib/Properties.hs
index f60758f..1b6cab8 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))
@@ -175,6 +174,8 @@ checkTileset = do
       where checkTileProperty :: Property -> LintWriter Tileset
             checkTileProperty p@(Property name _) = case name of
               "collides" -> isBool p
+              -- named tiles are needed for scripting and do not hurt otherwise
+              "name" -> isString p
               _ -> warn $ "unknown tile property " <> prettyprint name
                         <> " in tile with global id "
                         <> showText (tileId tile)
@@ -195,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
 
@@ -223,11 +226,16 @@ 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
-  "url" -> unwrapURI (Proxy @"website") p
-    (dependsOn . Link)
-    (const $ forbid "using \"url\" to open local html files is disallowed.")
+checkObjectProperty :: Property -> LintWriter Object
+checkObjectProperty p@(Property name _) = do
+ obj <- askContext
+ case name of
+  "url" -> do
+    unwrapURI (Proxy @"website") p
+      (dependsOn . Link)
+      (const $ forbid "using \"url\" to open local html files is disallowed.")
+    unless (objectType obj == "website")
+      $ complain "\"url\" can only be set for objects of type \"website\""
   "allowApi" -> forbidProperty name
   "getBadge" -> do
     when (1 /= length (getProperties obj))
@@ -247,8 +255,44 @@ checkObjectProperty obj p@(Property name _) = case name of
               (Just w, Just h) | w /= 0 && h /= 0 ->
                  BadgeRect objectX objectY w h
               _ -> BadgePoint objectX objectY
-  _ -> warn $ "unknown object property " <> prettyprint name <> "."
-
+  "soundRadius" -> do
+    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" ] -> do
+        isBool p
+        suggestPropertyName' "door"
+    -- extended API for doors and bells
+    | name `elem` [ "openLayer", "closeLayer" ] -> do
+        isString 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
@@ -392,8 +436,24 @@ checkTileLayerProperty p@(Property name _value) = case name of
     --     False -> warn "property \"collides\" set to 'false' is useless."
     "getBadge" -> complain "\"getBadge\" must be set on an \"objectgroup\" \
                            \ layer; it does not work on tile layers."
+
+    -- extended API stuff
+    "zone" -> do
+      isString p
+      uselessEmptyLayer
+    -- name on tile layer unsupported
     "name" -> isUnsupported
-    _ ->
+    _ | name `elem` [ "doorVariable", "bindVariable", "bellVariable" ]
+        -> do { isString p; requireProperty "zone" }
+      | name `elem` [ "code", "openTriggerMessage", "closeTriggerMessage"]
+        -> do { isString p; requireProperty "doorVariable" }
+      | name `elem` [ "autoOpen", "autoClose"]
+        -> do { isBool 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
@@ -485,7 +545,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."
 
@@ -497,12 +557,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 -----
 
@@ -573,16 +642,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
@@ -598,15 +668,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