summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/CheckDir.hs2
-rw-r--r--lib/Properties.hs48
-rw-r--r--lib/Tiled2.hs13
-rw-r--r--lib/Util.hs5
4 files changed, 52 insertions, 16 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 18:07:17 +0000