From c61f8b2ac2ecf5ff96401e1a913d41a6d5a4a343 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Sat, 4 Dec 2021 03:01:37 +0100 Subject: refuse doubled names --- lib/CheckDir.hs | 2 +- lib/Properties.hs | 48 +++++++++++++++++++++++++++++++++--------------- lib/Tiled2.hs | 13 +++++++++++++ lib/Util.hs | 5 +++++ 4 files changed, 52 insertions(+), 16 deletions(-) (limited to 'lib') diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index 17c6f78..5ad195f 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -9,6 +9,7 @@ -- | Module that contains high-level checking for an entire directory module CheckDir (recursiveCheckDir, DirResult(..), resultIsFatal) where +import Badges (badgeJson) import CheckMap (MapResult (..), loadAndLintMap) import Control.Monad (void) import Control.Monad.Extra (mapMaybeM) @@ -32,7 +33,6 @@ import System.FilePath.Posix (takeDirectory) import Types (Dep (Local, LocalMap), Level (..), hintLevel) import Util (PrettyPrint (prettyprint)) -import Badges (badgeJson) -- based on the startling observation that Data.Map has lower complexity diff --git a/lib/Properties.hs b/lib/Properties.hs index 27076cb..d65c9da 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -13,18 +13,20 @@ module Properties (checkMap, checkTileset, checkLayer) where import Control.Monad (forM_, unless, when) import Data.Text (Text, isPrefixOf) import qualified Data.Vector as V -import Tiled2 (HasProperties (adjustProperties, getProperties), - IsProperty (asProperty), Layer (..), - Object (..), Property (..), PropertyValue (..), - Tiledmap (..), Tileset (..)) -import Util (layerIsEmpty, naiveEscapeHTML, prettyprint, - showText) +import Tiled2 (HasName (getName), + HasProperties (adjustProperties, getProperties), + HasTypeName (typeName), IsProperty (asProperty), + Layer (..), Object (..), Property (..), + PropertyValue (..), Tiledmap (..), Tileset (..)) +import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, + prettyprint, showText) import Badges (Badge (Badge), BadgeArea (BadgePoint, BadgeRect), BadgeToken, parseToken) import Data.Data (Proxy (Proxy)) import Data.Maybe (fromMaybe, isJust) +import qualified Data.Set as S import GHC.TypeLits (KnownSymbol) import LintConfig (LintConfig (..)) import LintWriter (LintWriter, adjust, askContext, askFileDepth, @@ -55,6 +57,9 @@ checkMap = do hasLayer (flip containsProperty "exitUrl" . getProperties) "The map must contain at least one layer with the property \"exitUrl\" set." + refuseDoubledNames (tiledmapLayers tiledmap) + refuseDoubledNames (tiledmapTilesets tiledmap) + -- reject maps not suitable for workadventure unless (tiledmapOrientation tiledmap == "orthogonal") $ complain "The map's orientation must be set to \"orthogonal\"." @@ -106,6 +111,8 @@ checkTileset = do -- TODO: can tilesets be non-local dependencies? unwrapPath (tilesetImage tileset) (dependsOn . Local) + refuseDoubledNames (getProperties tileset) + -- reject tilesets unsuitable for workadventure unless (tilesetTilewidth tileset == 32 && tilesetTileheight tileset == 32) $ complain "Tilesets must have tile size 32×32." @@ -135,8 +142,10 @@ checkLayer = do when (isJust (layerImage layer)) $ complain "imagelayer are not supported." + refuseDoubledNames (getProperties layer) + case layerType layer of - "tilelayer" -> mapM_ checkLayerProperty (getProperties layer) + "tilelayer" -> mapM_ checkTileLayerProperty (getProperties layer) "group" -> pure () "objectgroup" -> do -- TODO: this still retains object group layers, just empties them out. @@ -190,8 +199,8 @@ checkObjectGroupProperty p@(Property name _) = case name of -- -- It gets a reference to its own layer since sometimes the presence -- of one property implies the presence or absense of another. -checkLayerProperty :: Property -> LintWriter Layer -checkLayerProperty p@(Property name _value) = case name of +checkTileLayerProperty :: Property -> LintWriter Layer +checkTileLayerProperty p@(Property name _value) = case name of "jitsiRoom" -> do lintConfig configAssemblyTag >>= setProperty "jitsiRoomAdminTag" @@ -302,7 +311,6 @@ checkLayerProperty p@(Property name _value) = case name of True -> pure () False -> warn "property \"collides\" set to 'false' is useless." "name" -> isUnsupported - -- all properties relating to scripting are handled the same _ -> warn $ "unknown property type " <> prettyprint name where @@ -325,8 +333,21 @@ checkLayerProperty p@(Property name _value) = case name of $ warn ("property " <> prettyprint name <> " set on an empty layer is useless.") - - +-- | refuse doubled names in everything that's somehow a collection of names +refuseDoubledNames + :: (HasName a, HasTypeName a) + => (Foldable t, Functor t) + => t a + -> LintWriter b +refuseDoubledNames things = foldr folding base things mempty + where + -- this accumulates a function that complains about things it's already seen + folding thing cont seen = do + when (name `elem` seen) + $ complain $ "cannot use " <> typeName (mkProxy thing) <> " name \"" <> name <> "\" twice" + cont (S.insert name seen) + where name = getName thing + base _ = pure () --------- Helper functions & stuff --------- @@ -380,9 +401,6 @@ unwrapString (Property name value) f = case value of StrProp str -> f str _ -> complain $ "type error: property " <> prettyprint name <> " should be of type string." -unwrapString' :: Property -> LintWriter a -> LintWriter a -unwrapString' prop f = unwrapString prop (const f) - -- | same as unwrapString, but also forbids http:// as prefix unwrapLink :: Property -> (Text -> LintWriter a) -> LintWriter a unwrapLink (Property name value) f = case value of diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 7e8f773..44f2db7 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} @@ -24,6 +25,7 @@ import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) import Data.Map (Map) import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy) import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T @@ -395,12 +397,23 @@ instance HasProperties Tiledmap where adjustProperties f tiledmap = tiledmap { tiledmapProperties = f (getProperties tiledmap) } +class HasTypeName a where + typeName :: Proxy a -> Text +instance HasTypeName Layer where + typeName _ = "layer" +instance HasTypeName Tileset where + typeName _ = "tileset" +instance HasTypeName Property where + typeName _ = "property" + class HasName a where getName :: a -> Text instance HasName Layer where getName = layerName instance HasName Tileset where getName = tilesetName +instance HasName Property where + getName (Property n _) = n class IsProperty a where asProperty :: a -> PropertyValue diff --git a/lib/Util.hs b/lib/Util.hs index 948b725..c082bfe 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -7,11 +7,16 @@ module Util where import Data.Aeson as Aeson +import Data.Proxy (Proxy (..)) import Data.Text (Text) import qualified Data.Text as T import Tiled2 (Layer (layerData), PropertyValue (..), Tileset (tilesetName), layerName, mkTiledId) +-- | helper function to create proxies +mkProxy :: a -> Proxy a +mkProxy = const Proxy + -- | haskell's many string types are FUN … showText :: Show a => a -> Text showText = T.pack . show -- cgit v1.2.3