add suggestions for misspelled properties

(suggestions are shown only if they have a Damerau-Levenshtein distance
<= 4, which seems to yield reasonably good results)

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 ----