diff options
Diffstat (limited to '')
-rw-r--r-- | lib/Properties.hs | 114 |
1 files changed, 77 insertions, 37 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index 6d7e03c..364a579 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -4,43 +4,72 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | Contains checks for custom ties of the map json module Properties (checkMap, checkTileset, checkLayer) where -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 -import Tiled (Layer (..), Object (..), Property (..), - PropertyValue (..), Tile (..), Tiledmap (..), - Tileset (..)) -import TiledAbstract (HasName (..), HasProperties (..), - HasTypeName (..), IsProperty (..)) -import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, - prettyprint, showText) - -import Badges (Badge (Badge), - BadgeArea (BadgePoint, BadgeRect), BadgeToken, - parseToken) -import Data.Data (Proxy (Proxy)) -import Data.List ((\\)) -import Data.Maybe (fromMaybe, isJust) -import Data.Set (Set) -import qualified Data.Set as S -import GHC.TypeLits (KnownSymbol) -import LayerData (Collision, layerOverlaps) -import LintConfig (LintConfig (..)) -import LintWriter (LintWriter, adjust, askContext, askFileDepth, - complain, dependsOn, forbid, lintConfig, - offersBadge, offersEntrypoint, suggest, warn, zoom) -import Paths (PathResult (..), RelPath (..), getExtension, - isOldStyle, parsePath) -import Types (Dep (Link, Local, LocalMap, MapLink)) -import Uris (SubstError (..), applySubst, parseUri) - +import Control.Monad (forM, forM_, unless, when) +import Data.Text (Text, intercalate, isPrefixOf) +import qualified Data.Text as T +import qualified Data.Vector as V +import Tiled (Layer (..), Object (..), Property (..), + PropertyValue (..), Tile (..), + Tiledmap (..), Tileset (..)) +import TiledAbstract (HasName (..), HasProperties (..), + HasTypeName (..), IsProperty (..)) +import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, + prettyprint, showText) + +import Badges (Badge (Badge), + BadgeArea (BadgePoint, BadgeRect), + BadgeToken, parseToken) +import Data.Data (Proxy (Proxy)) +import Data.List ((\\)) +import Data.Maybe (fromMaybe, isJust) +import Data.Set (Set) +import qualified Data.Set as S +import Data.Text.Metrics (damerauLevenshtein) +import Data.Vector (Vector) +import GHC.TypeLits (KnownSymbol) +import LayerData (Collision, layerOverlaps) +import LintConfig (LintConfig (..)) +import LintWriter (LintWriter, adjust, askContext, + askFileDepth, complain, dependsOn, forbid, + lintConfig, offersBadge, offersEntrypoint, + suggest, warn, zoom) +import Paths (PathResult (..), RelPath (..), getExtension, + isOldStyle, parsePath) +import Types (Dep (Link, Local, LocalMap, MapLink)) +import Uris (SubstError (..), applySubst, parseUri) + + + +knownMapProperties :: Vector Text +knownMapProperties = V.fromList + [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" ] + +knownTilesetProperties :: Vector Text +knownTilesetProperties = V.fromList + [ "tilesetCopyright", "collides"] + +knownObjectProperties :: Vector Text +knownObjectProperties = V.fromList + [ "name", "url", "getBadge", "soundRadius", "default", "persist", "openLayer" + , "closeLayer", "door", "bell", "openSound", "closeSound", "bellSound" + , "allowapi"] + +knownTileLayerProperites :: Vector Text +knownTileLayerProperites = V.fromList + [ "jitsiRoom", "jitsiTrigger", "jitsiTriggerMessage", "jitsiWidth", "bbbRoom" + , "bbbTrigger", "bbbTriggerMessage", "playAudio", "audioLoop", "audioVolumne" + , "openWebsite", "openWebsiteTrigger", "openWebsiteTriggerMessage", "openTag" + , "exitUrl", "startLayer", "silent", "getBadge", "zone", "name", "doorVariable" + , "bindVariable", "bellVariable", "code", "openTriggerMessage" + , "closeTriggerMessage", "autoOpen", "autoClose", "bellButtonText", "bellPopup" + , "enterValue", "leaveValue" ] -- | Checks an entire map for "general" lints. -- @@ -119,7 +148,7 @@ checkMapProperty p@(Property name _) = case name of -> complain $ "property " <> name <> " should be set on layers, not the map directly" | otherwise - -> complain $ "unknown map property " <> prettyprint name + -> warnUnknown p knownMapProperties -- | check an embedded tile set. @@ -176,9 +205,9 @@ checkTileset = do "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) + _ -> warnUnknown' ("unknown tile property " + <> prettyprint name <> " in tile with global id " + <> showText (tileId tile)) p knownTilesetProperties -- | collect lints on a single map layer @@ -293,7 +322,7 @@ checkObjectProperty p@(Property name _) = do | T.toLower name `elem` [ "allowapi" ] -> forbidProperty name | otherwise -> - warn $ "unknown object property " <> prettyprint name <> "." + warnUnknown p knownObjectProperties -- | Checks a single (custom) property of an objectgroup layer checkObjectGroupProperty :: Property -> LintWriter Layer @@ -452,7 +481,7 @@ checkTileLayerProperty p@(Property name _value) = case name of , "allowapi" ] -> forbidProperty name | otherwise -> - warn $ "unknown property type " <> prettyprint name + warnUnknown p knownTileLayerProperites where requireProperty req = propertyRequiredBy req name isUnsupported = warn $ "property " <> name <> " is not (yet) supported by walint." @@ -502,6 +531,17 @@ refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempt base _ = pure () +warnUnknown' :: Text -> Property -> Vector Text -> LintWriter a +warnUnknown' msg (Property name _) knowns = + if snd minDist < 4 + then warn (msg <> ", perhaps you meant " <> prettyprint (fst minDist) <> "?") + else warn msg + where dists = V.map (\n -> (n, damerauLevenshtein name n)) knowns + minDist = V.minimumBy (\(_,a) (_,b) -> compare a b) dists + +warnUnknown :: Property -> Vector Text -> LintWriter a +warnUnknown p@(Property name _) = + warnUnknown' ("unknown property " <> prettyprint name) p ---- General functions ---- |