refuse doubled names

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