diff options
| -rw-r--r-- | lib/Properties.hs | 75 |
1 files changed, 41 insertions, 34 deletions
diff --git a/lib/Properties.hs b/lib/Properties.hs index f645392..035b76a 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -45,7 +45,6 @@ import Types (Dep (Link, Local, LocalMap, MapLink)) import Uris (SubstError (..), applySubsts) - knownMapProperties :: Vector Text knownMapProperties = V.fromList [ "mapName", "mapDescription", "mapCopyright", "mapLink", "script" ] @@ -113,7 +112,7 @@ checkMap = do let missingMetaInfo = ["mapName","mapDescription","mapLink"] - \\ fmap getName (getProperties tiledmap) + \\ map getName (getProperties tiledmap) unless (null missingMetaInfo) $ suggest $ "consider adding meta information to your map using the " @@ -144,13 +143,13 @@ checkMapProperty p@(Property name _) = case name of (const $ forbid "scripts loaded from local files are disallowed") | name `elem` ["jitsiRoom", "playAudio", "openWebsite" , "url", "exitUrl", "silent", "getBadge"] - -> complain $ "property " <> name + -> complain $ "property " <> name <> " should be set on layers, not the map directly" | otherwise - -> warnUnknown p knownMapProperties + -> warnUnknown p knownMapProperties --- | check an embedded tile set. +-- | check an embedded tileset. -- -- Important to collect dependency files checkTileset :: LintWriter Tileset @@ -178,9 +177,10 @@ checkTileset = do when (isJust (tilesetFileName tileset)) $ complain "The \"filename\" property on tilesets was removed; use \"image\" instead (and perhaps a newer version of the Tiled Editor)." + -- check properties of individual tiles tiles' <- forM (tilesetTiles tileset) $ mapM $ \tile -> do mapM_ (checkTileProperty tile) (getProperties tile) - zoom (const tileset) (const tile) $ mapM_ checkTileThing' (getProperties tile) + zoom (const tileset) (const tile) $ mapM_ (checkTileThing True) (getProperties tile) adjust (\t -> t { tilesetTiles = tiles' }) @@ -189,7 +189,7 @@ checkTileset = do case tilesetTiles tileset of Nothing -> pure () - Just tiles -> refuseDoubledThings tileId + Just tiles -> ifDoubledThings tileId -- can't set properties on the same tile twice (\tile -> complain $ "cannot set properties on the \ \tile with the id" <> show (tileId tile) <> "twice.") @@ -202,9 +202,6 @@ checkTileset = do "collides" -> warn "property \"collides\" should be set on individual tiles, not the tileset" _ -> warn $ "unknown tileset property " <> prettyprint name - checkTileThing' :: Property -> LintWriter Tile - checkTileThing' = checkTileThing True - checkTileProperty :: Tile -> Property -> LintWriter Tileset checkTileProperty tile p@(Property name _) = case name of @@ -213,10 +210,9 @@ checkTileset = do "name" -> isString p "tilesetCopyright" -> warn "the \"tilesetCopyright\" property should be set on the entire tileset, \ \not an individual tile." - -- _ -> warnUnknown' ("unknown tile property " - -- <> prettyprint name <> " in tile with global id " - -- <> showText (tileId tile)) p knownTilesetProperties - _ -> pure () + _ -> warnUnknown' ("unknown tile property " + <> prettyprint name <> " in tile with global id " + <> show (tileId tile)) p knownTilesetProperties -- | collect lints on a single map layer @@ -241,7 +237,7 @@ checkLayer = do adjust (\l -> l { layerObjects = objs }) -- all objects which don't define badges - let publicObjects = fmap (V.filter (not . (`containsProperty` "getBadge"))) objs + let publicObjects = map (V.filter (not . (`containsProperty` "getBadge"))) objs -- remove badges from output adjust $ \l -> l { layerObjects = publicObjects @@ -326,7 +322,7 @@ checkObjectProperty p@(Property name _) = do suggestPropertyName' "door" suggestPropertyName "soundRadius" "set \"soundRadius\" to limit the door sound to a certain area." - | T.toLower name `elem` [ "allowapi" ] + | T.toLower name == "allowapi" -> forbidProperty name | otherwise -> warnUnknown p knownObjectProperties @@ -340,18 +336,26 @@ checkObjectGroupProperty (Property name _) = case name of --- | Checks a single (custom) property of a "normal" tile layer -checkTileThing :: (HasProperties a, HasName a, HasData a) => Bool -> Property -> LintWriter a +-- | Checks a single (custom) property. Since almost all properties +-- can be set on tile layer AND on tilesets, this function aims to +-- be generic over both — the only difference is that tilesets can't +-- have exits, which is specified by the sole boolean argument +checkTileThing + :: (HasProperties a, HasName a, HasData a) + => Bool -> Property -> LintWriter a checkTileThing removeExits p@(Property name _value) = case name of "jitsiRoom" -> do + uselessEmptyLayer + -- members of an assembly should automatically get + -- admin rights in jitsi (prepending "assembly-" here + -- to avoid namespace clashes with other admins) lintConfig configAssemblyTag >>= setProperty "jitsiRoomAdminTag" - . ("assembly-" <>) -- prepend "assembly-" to avoid namespace clashes - uselessEmptyLayer + . ("assembly-" <>) unwrapString p $ \jitsiRoom -> do suggestProperty $ Property "jitsiTrigger" "onaction" - -- prepend jitsi room names to avoid name clashes + -- prevents namespace clashes for jitsi room names unless ("shared" `isPrefixOf` jitsiRoom) $ do assemblyname <- lintConfig configAssemblyTag setProperty "jitsiRoom" (assemblyname <> "-" <> jitsiRoom) @@ -412,20 +416,23 @@ checkTileThing removeExits p@(Property name _value) = case name of _ -> complain "There's a path I don't understand here. Perhaps try \ \asking a human?" ) - $ \path -> + ( \path -> let ext = getExtension path in - if | isOldStyle path -> - complain "Old-Style inter-repository links (using {<placeholder>}) \ - \cannot be used at divoc bb3; please use world:// instead \ - \(see https://di.c3voc.de/howto:world)." + if | isOldStyle path -> do + eventslug <- lintConfig configEventSlug + complain $ + "Old-Style inter-repository links (using {<placeholder>}) \ + \cannot be used at "<>eventslug<>"; please use world:// \ + \instead (see https://di.c3voc.de/howto:world)." | ext == "tmx" -> complain "Cannot use .tmx map format; use Tiled's json export instead." | ext /= "json" -> complain "All exit links must link to .json files." | otherwise -> dependsOn . LocalMap $ path + ) else do - warn "exitUrls in Tilesets are not properly supported; if you want to add an \ - \exit, please use a tile layer instead." + warn "exitUrls in Tilesets are not unsupported; if you want to \ + \add an exit, please use a tile layer instead." "exitSceneUrl" -> deprecatedUseInstead "exitUrl" "exitInstance" -> @@ -511,19 +518,19 @@ refuseDoubledNames :: (Container t, HasName (Element t), HasTypeName (Element t)) => t -> LintWriter b -refuseDoubledNames = refuseDoubledThings - getName +refuseDoubledNames = ifDoubledThings getName (\thing -> complain $ "cannot use " <> typeName (mkProxy thing) <> " name " <> getName thing <> " multiple times.") --- | refuse doubled things via equality on after applying some function -refuseDoubledThings +-- | do `ifDouble` if any element of `things` occurs more than once under +-- the function `f` +ifDoubledThings :: (Eq a, Ord a, Container t) => (Element t -> a) -> (Element t -> LintWriter b) -> t -> LintWriter b -refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) +ifDoubledThings f ifDouble things = foldr folding base things (mempty, mempty) where folding thing cont (seen, twice) | f thing `elem` seen && f thing `notElem` twice = do @@ -533,7 +540,7 @@ refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempt cont (S.insert (f thing) seen, twice) base _ = pure () - +-- | we don't know this property; give suggestions for ones with similar names warnUnknown' :: Text -> Property -> Vector Text -> LintWriter a warnUnknown' msg (Property name _) knowns = if snd minDist < 4 |