diff --git a/lib/Badges.hs b/lib/Badges.hs
index efb4e77ab36925c7567edd13f5eacb1dc25c1190..65433a1e3c933998f42541a94183851073926621 100644
--- a/lib/Badges.hs
+++ b/lib/Badges.hs
@@ -22,10 +22,10 @@ data BadgeArea =
, areaY :: Double
}
| BadgeRect
- { areaX :: Double
- , areaY :: Double
- , areaWidth :: Double
- , areaHeight :: Double
+ { areaX :: Double
+ , areaY :: Double
+ , areaWidth :: Double
+ , areaHeight :: Double
}
deriving (Ord, Eq, Generic, Show)
@@ -41,7 +41,7 @@ instance ToJSON BadgeToken where
toJSON (BadgeToken text) = toJSON text
parseToken :: Text -> Maybe BadgeToken
-parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text) -- TODO: add character limit
+parseToken text = if text =~ ("^[a-zA-Z0-9]{50}$" :: Text)
then Just (BadgeToken text)
else Nothing
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 779123d127e090bacac132b399eb5e65cf5e1e44..0fe76bad1f57b4e69db640e23cc895f7d90c9d75 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -61,9 +61,6 @@ instance ToJSON MapResult where
[ "layer" .= CollectedLints (fmap getName <$> mapresultLayer res)
, "tileset" .= CollectedLints (fmap getName <$> mapresultTileset res)
, "general" .= mapresultGeneral res
- -- TODO: not sure if these are necessary of even useful
- --, "depends" .= mapresultDepends res
- --, "provides" .= mapresultProvides res
]
newtype CollectedLints = CollectedLints (Map Hint [Text])
diff --git a/lib/Paths.hs b/lib/Paths.hs
index 99774c53bbecd22e0e03e9c17ff77dc329e8f411..7fae0dfcff914e1b0173345dc13709595200c5b8 100644
--- a/lib/Paths.hs
+++ b/lib/Paths.hs
@@ -36,9 +36,10 @@ parsePath text =
-- how many steps upwards in the tree?
up = length . filter (".." ==) . T.splitOn "/" $ prefix
parts = T.splitOn "#" rest
+ -- `head` is unsafe, but splitOn will always produce lists with at least one element
path = head parts
fragment = if length parts >= 2
- then Just $ T.concat $ tail parts -- TODO!
+ then Just $ T.concat $ tail parts
else Nothing
instance PrettyPrint RelPath where
diff --git a/lib/Properties.hs b/lib/Properties.hs
index 9c61aedc282948cf6da99a3e957aa55eb2c7b25b..6a8c16646265583e428dfc6b1e32f58196b9fcad 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -130,7 +130,6 @@ checkMapProperty p@(Property name _) = case name of
checkTileset :: LintWriter Tileset
checkTileset = do
tileset <- askContext
- -- TODO: can tilesets be non-local dependencies?
unwrapPath (tilesetImage tileset) (dependsOn . Local)
refuseDoubledNames (getProperties tileset)
@@ -154,8 +153,16 @@ checkTileset = do
-- check individual tileset properties
mapM_ checkTilesetProperty (fromMaybe mempty $ tilesetProperties tileset)
- -- check individual tile definitions
- mapM_ checkTile (fromMaybe mempty $ tilesetTiles tileset)
+ case tilesetTiles tileset of
+ Nothing -> pure ()
+ Just tiles -> do
+ -- can't set properties on the same tile twice
+ refuseDoubledThings tileId
+ (\tile -> complain $ "cannot set properties on the \
+ \tile with the id" <> showText (tileId tile) <> "twice.")
+ tiles
+
+ mapM_ checkTile tiles
where
checkTilesetProperty :: Property -> LintWriter Tileset
checkTilesetProperty p@(Property name _value) = case name of
@@ -164,8 +171,8 @@ checkTileset = do
checkTile :: Tile -> LintWriter Tileset
checkTile tile = do
- -- TODO: refused doubled IDs?
- mapM_ checkTileProperty (fromMaybe mempty $ tileProperties tile)
+ refuseDoubledNames (getProperties tile)
+ mapM_ checkTileProperty (getProperties tile)
where checkTileProperty :: Property -> LintWriter Tileset
checkTileProperty p@(Property name _) = case name of
"collides" -> isBool p
@@ -401,22 +408,30 @@ refuseDoubledNames
=> (Foldable t, Functor t)
=> t a
-> LintWriter b
-refuseDoubledNames things = foldr folding base things (mempty,mempty)
+refuseDoubledNames = refuseDoubledThings
+ getName
+ (\thing -> complain $ "cannot use " <> typeName (mkProxy thing) <> " name "
+ <> getName thing <> " multiple times.")
+
+-- | refuse doubled things via equality on after applying some function
+refuseDoubledThings
+ :: (Eq a, Ord a, Foldable t, Functor t)
+ => (a' -> a)
+ -> (a' -> LintWriter b)
+ -> t a'
+ -> LintWriter b
+refuseDoubledThings f ifDouble things = foldr folding base things (mempty, mempty)
where
- -- this accumulates a function that complains about things it's
- -- already seen, except if they've already occured twice and then
- -- occur again …
folding thing cont (seen, twice)
- | name `elem` seen && name `notElem` twice = do
- complain $ "cannot use " <> typeName (mkProxy thing)
- <> " name \"" <> name <> "\" multiple times."
- cont (seen, S.insert name twice)
+ | f thing `elem` seen && f thing `notElem` twice = do
+ ifDouble thing
+ cont (seen, S.insert (f thing) twice)
| otherwise =
- cont (S.insert name seen, twice)
- where name = getName thing
+ cont (S.insert (f thing) seen, twice)
base _ = pure ()
+
---- General functions ----
unlessElement
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
index a092b678d5b02b9d6715f890a556fe672b5c5f0d..fa876ee477b83d48741f3c14f93423b7c7c222ec 100644
--- a/lib/Tiled.hs
+++ b/lib/Tiled.hs
@@ -52,7 +52,6 @@ mkTiledId i = GlobalId { unGlobalId = i }
newtype LocalId = LocalId { unLocalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
--- | TODO: type-check colours?
type Color = Text
-- | A custom tiled property, which just has a name and a value.
diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs
index f7bbbb9a065221c9fc1fede1feb7edc554f4b765..88dd2eefea47cc48a302f492d6d1c774176e8bea 100644
--- a/lib/TiledAbstract.hs
+++ b/lib/TiledAbstract.hs
@@ -2,11 +2,12 @@
module TiledAbstract where
-import Data.Maybe (fromMaybe)
-import Data.Proxy (Proxy)
-import Data.Text (Text)
-import Tiled (Layer (..), Property (..), PropertyValue (..),
- Tiledmap (..), Tileset (..))
+import Data.Maybe (fromMaybe)
+import Data.Proxy (Proxy)
+import Data.Text (Text)
+import qualified Data.Vector as V
+import Tiled (Layer (..), Property (..), PropertyValue (..),
+ Tile (..), Tiledmap (..), Tileset (..))
class HasProperties a where
getProperties :: a -> [Property]
@@ -22,6 +23,12 @@ instance HasProperties Tileset where
adjustProperties f tileset = tileset
{ tilesetProperties = f (getProperties tileset) }
+instance HasProperties Tile where
+ getProperties = V.toList . fromMaybe mempty . tileProperties
+ adjustProperties f tile = tile
+ { tileProperties = (fmap V.fromList . f) (getProperties tile) }
+
+
instance HasProperties Tiledmap where
getProperties = fromMaybe mempty . tiledmapProperties
adjustProperties f tiledmap = tiledmap
diff --git a/lib/Types.hs b/lib/Types.hs
index 6f80d556760498fcc1bea7243b9eb50a1a5edfe8..978ada2212b43a341936cf41507590133f3f50c3 100644
--- a/lib/Types.hs
+++ b/lib/Types.hs
@@ -51,7 +51,6 @@ instance HasArguments Level where
data Lint = Depends Dep | Offers Text | Lint Hint | Badge Badge
deriving (Ord, Eq, Generic, ToJSONKey)
--- | TODO: add a reasonable representation of possible urls
data Dep = Local RelPath | Link Text | MapLink Text | LocalMap RelPath
deriving (Generic, Ord, Eq)
@@ -84,7 +83,7 @@ instance PrettyPrint Lint where
" Info: found a badge."
instance PrettyPrint Hint where
- prettyprint (Hint level msg) = " " <> (showText level) <> ": " <> msg
+ prettyprint (Hint level msg) = " " <> showText level <> ": " <> msg
instance ToJSON Lint where
toJSON (Lint h) = toJSON h