diff options
| -rw-r--r-- | lib/Badges.hs | 10 | ||||
| -rw-r--r-- | lib/CheckMap.hs | 3 | ||||
| -rw-r--r-- | lib/Paths.hs | 3 | ||||
| -rw-r--r-- | lib/Properties.hs | 45 | ||||
| -rw-r--r-- | lib/Tiled.hs | 1 | ||||
| -rw-r--r-- | lib/TiledAbstract.hs | 17 | ||||
| -rw-r--r-- | lib/Types.hs | 3 |
7 files changed, 50 insertions, 32 deletions
diff --git a/lib/Badges.hs b/lib/Badges.hs index efb4e77..65433a1 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 779123d..0fe76ba 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 99774c5..7fae0df 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 9c61aed..6a8c166 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 a092b67..fa876ee 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 f7bbbb9..88dd2ee 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 6f80d55..978ada2 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 |