diff options
| -rw-r--r-- | lib/LintWriter.hs | 21 | ||||
| -rw-r--r-- | lib/Properties.hs | 127 |
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 |