summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/CheckMap.hs5
-rw-r--r--lib/Properties.hs21
-rw-r--r--lib/Tiled2.hs251
3 files changed, 79 insertions, 198 deletions
diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs
index 036f4e8..d7d45c0 100644
--- a/lib/CheckMap.hs
+++ b/lib/CheckMap.hs
@@ -23,7 +23,8 @@ import LintWriter (LintResult (..), LintWriter, askContext,
filterLintLevel, lintToDep, resultToDeps,
resultToLints, resultToOffers, runLintWriter)
import Properties (checkLayerProperty, checkMap, checkTileset)
-import Tiled2 (Layer (layerName, layerProperties),
+import Tiled2 (HasProperties (getProperties),
+ Layer (layerName, layerProperties),
LoadResult (..),
Tiledmap (tiledmapLayers, tiledmapTilesets),
Tileset (tilesetName), loadTiledmap)
@@ -96,7 +97,7 @@ runLinter tiledmap depth = MapResult
checkLayer :: LintWriter Layer
checkLayer = do
layer <- askContext
- mapM_ checkLayerProperty (layerProperties layer)
+ mapM_ checkLayerProperty (getProperties layer)
-- human-readable lint output, e.g. for consoles
instance PrettyPrint (Level, MapResult) where
diff --git a/lib/Properties.hs b/lib/Properties.hs
index ed97355..1b0569d 100644
--- a/lib/Properties.hs
+++ b/lib/Properties.hs
@@ -8,10 +8,12 @@ module Properties (checkLayerProperty, checkMap, checkTileset) where
import Control.Monad (unless, when)
import Data.Text (Text, isPrefixOf)
-import Tiled2 (Layer (..), Property (..), PropertyValue (..),
+import Tiled2 (HasProperties (getProperties), Layer (..),
+ Property (..), PropertyValue (..),
Tiledmap (..), Tileset (..))
import Util (layerIsEmpty, prettyprint)
+import Data.Maybe (fromMaybe)
import LintWriter (LintWriter, askContext, askFileDepth, complain,
dependsOn, forbid, offersEntrypoint, suggest,
warn)
@@ -29,14 +31,14 @@ checkMap = do
tiledmap <- askContext
-- test other things
- mapM_ checkMapProperty (tiledmapProperties tiledmap)
+ mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap)
-- some layers should exist
hasLayerNamed "start" (const True)
"The map must have one layer named \"start\""
hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType)
"The map must have one layer named \"floorLayer\" of type \"objectgroup\""
- hasLayer (flip containsProperty "exitUrl" . layerProperties)
+ hasLayer (flip containsProperty "exitUrl" . getProperties)
"The map must contain at least one layer with the property \"exitUrl\" set"
-- reject maps not suitable for workadventure
@@ -82,7 +84,7 @@ checkTileset tileset = do
-- TODO: check copyright!
requireProperty "copyright"
- mapM_ checkTilesetProperty (tilesetProperties tileset)
+ mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset)
checkTilesetProperty :: Property -> LintWriter Tileset
checkTilesetProperty p@(Property name value) = case name of
@@ -182,15 +184,6 @@ checkLayerProperty p@(Property name _value) = case name of
--------- Helper functions & stuff ---------
-class HasProperties a where
- getProperties :: a -> [Property]
-
-instance HasProperties Layer where
- getProperties = layerProperties
-
-instance HasProperties Tileset where
- getProperties = tilesetProperties
-
unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a
unlessHasProperty name andthen = do
layer <- askContext
@@ -229,7 +222,7 @@ suggestProperty (Property name value) =
-- | does this layer have the given property?
-containsProperty :: [Property] -> Text -> Bool
+containsProperty :: Foldable t => t Property -> Text -> Bool
containsProperty props name = any
(\(Property name' _) -> name' == name) props
diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs
index 3fc8c31..45b8ad0 100644
--- a/lib/Tiled2.hs
+++ b/lib/Tiled2.hs
@@ -2,29 +2,27 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
+
-- | This module provides Haskell types for Tiled's JSON exports, which you can
-- read about at http://doc.mapeditor.org/en/latest/reference/json-map-format/.
-- That said - as of the writing of this module the JSON documentation does not
-- cover some of the types and records that are available in the format. For
-- those you should read the TMX documentation at
-- http://doc.mapeditor.org/en/latest/reference/tmx-map-format/
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE ScopedTypeVariables #-}
module Tiled2 where
-import Control.Applicative ((<|>))
import Control.Exception (try)
import Control.Exception.Base (SomeException)
-import Control.Monad (forM)
import Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import Data.Aeson.Types (Parser, typeMismatch)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
-import Data.Functor ((<&>))
+import Data.Char (toLower)
import Data.Map (Map)
-import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Vector (Vector)
@@ -32,6 +30,14 @@ import GHC.Exts (fromList, toList)
import GHC.Generics (Generic)
+-- | options for Aeson's generic encoding and parsing functions
+aesonOptions :: Int -> Options
+aesonOptions l = defaultOptions
+ { omitNothingFields = True
+ , rejectUnknownFields = True
+ , fieldLabelModifier = drop l . map toLower
+ }
+
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
@@ -75,13 +81,6 @@ parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a
parseDefault o s d = fromMaybe d <$> o .:? s
-{-- | workadventure custom property
-data Property = Property { propertyName :: Text
- --, propertyType :: Text (unnecessary since always string)
- , propertyValue :: Text
- } deriving (Eq, Generic, Show)
--}
-
data PropertyValue = StrProp Text | BoolProp Bool
deriving (Eq, Generic, Show)
data Property = Property Text PropertyValue
@@ -145,46 +144,14 @@ data Object = Object { objectId :: Int
} deriving (Eq, Generic, Show)
instance FromJSON Object where
- parseJSON (A.Object o) = Object <$> o .: "id"
- <*> o .: "width"
- <*> o .: "height"
- <*> o .: "name"
- <*> o .: "type"
- <*> parseDefault o "properties" M.empty
- <*> o .: "visible"
- <*> o .: "x"
- <*> o .: "y"
- <*> o .: "rotation"
- <*> o .:? "gid"
- <*> parseDefault o "ellipse" False
- <*> (fmap . fmap . fmap) fromXYPair (o .:? "polygon")
- <*> (fmap . fmap . fmap) fromXYPair (o .:? "polyline")
- <*> parseDefault o "text" M.empty
- parseJSON invalid = typeMismatch "Object" invalid
-
+ parseJSON = genericParseJSON (aesonOptions 6)
instance ToJSON Object where
- toJSON Object{..} = omitNulls $
- object [ "id" .= objectId
- , "width" .= objectWidth
- , "height" .= objectHeight
- , "name" .= objectName
- , "type" .= objectType
- , "properties" .= objectProperties
- , "visible" .= objectVisible
- , "x" .= objectX
- , "y" .= objectY
- , "rotation" .= objectRotation
- , "gid" .= objectGid
- , "ellipse" .= objectEllipse
- , "polygon" .= (fmap . fmap) toXYPair objectPolygon
- , "polyline" .= (fmap . fmap) toXYPair objectPolyline
- , "text" .= objectText
- ]
+ toJSON = genericToJSON (aesonOptions 6)
-data Layer = Layer { layerWidth :: Double
+data Layer = Layer { layerWidth :: Maybe Double
-- ^ Column count. Same as map width for fixed-size maps.
- , layerHeight :: Double
+ , layerHeight :: Maybe Double
-- ^ Row count. Same as map height for fixed-size maps.
, layerName :: Text
-- ^ Name assigned to this layer
@@ -200,44 +167,19 @@ data Layer = Layer { layerWidth :: Double
-- ^ Array of GIDs. tilelayer only.
, layerObjects :: Maybe (Vector Object)
-- ^ Array of Objects. objectgroup only.
- , layerProperties :: [Property]
+ , layerProperties :: Maybe [Property]
-- ^ string key-value pairs.
, layerOpacity :: Float
-- ^ Value between 0 and 1
- , layerDraworder :: String
+ , layerDraworder :: Maybe String
-- ^ “topdown” (default) or “index”. objectgroup only.
+ , layerId :: Int
} deriving (Eq, Generic, Show)
instance FromJSON Layer where
- parseJSON (A.Object o) = Layer <$> (o .: "width" <|> pure 0)
- <*> (o .: "height" <|> pure 0)
- <*> o .: "name"
- <*> o .: "type"
- <*> o .: "visible"
- <*> o .: "x"
- <*> o .: "y"
- <*> (o .: "data" <|> pure Nothing)
- <*> o .:? "objects"
- <*> (o .:? "properties" <&> fromMaybe [])
- <*> o .: "opacity"
- <*> (o .: "draworder" <|> pure "topdown")
- parseJSON invalid = typeMismatch "Layer" invalid
-
+ parseJSON = genericParseJSON (aesonOptions 5)
instance ToJSON Layer where
- toJSON Layer{..} = omitNulls $
- object [ "width" .= layerWidth
- , "height" .= layerHeight
- , "name" .= layerName
- , "type" .= layerType
- , "visible" .= layerVisible
- , "x" .= layerX
- , "y" .= layerY
- , "data" .= layerData
- , "objects" .= layerObjects
- , "properties" .= layerProperties
- , "opacity" .= layerOpacity
- , "draworder" .= layerDraworder
- ]
+ toJSON = genericToJSON (aesonOptions 5)
data Terrain = Terrain { terrainName :: String
@@ -264,35 +206,28 @@ data Frame = Frame { frameDuration :: Int
instance FromJSON Frame where
parseJSON (A.Object o) = Frame <$> o .: "duration"
- <*> o .: "tileId"
+ <*> o .: "tileid"
parseJSON invalid = typeMismatch "Frame" invalid
instance ToJSON Frame where
toJSON Frame{..} = object [ "duration" .= frameDuration
- , "tileId" .= frameTileId
+ , "tileid" .= frameTileId
]
-data Tile = Tile { tileId :: LocalId
- , tileProperties :: Map Text Text
+data Tile = Tile { tileId :: Int
+ , tileProperties :: Maybe (Vector Value)
, tileImage :: Maybe Value
, tileObjectGroup :: Maybe (Vector Object)
, tileAnimation :: Maybe (Vector Frame)
} deriving (Eq, Generic, Show)
instance FromJSON Tile where
- parseJSON (A.Object o) = Tile 0 <$> (o .: "properties" <|> pure mempty)
- <*> (o .: "image" <|> pure Nothing)
- <*> (o .: "objectGroup" <|> pure mempty)
- <*> (o .: "animation" <|> pure mempty)
- parseJSON invalid = typeMismatch "Tile" invalid
+ parseJSON = genericParseJSON (aesonOptions 4)
instance ToJSON Tile where
- toJSON Tile{..} = object [ "properties" .= tileProperties
- , "image" .= tileImage
- , "objectGroup" .= tileObjectGroup
- , "animation" .= tileAnimation
- ]
+ toJSON = genericToJSON (aesonOptions 4)
+
data Tileset = Tileset { tilesetFirstgid :: GlobalId
@@ -309,136 +244,88 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId
-- ^ Width of source image in pixels
, tilesetImageheight :: Int
-- ^ Height of source image in pixels
- , tilesetProperties :: [Property]
+ , tilesetProperties :: Maybe [Property]
-- ^ String key-value pairs
- , tilesetPropertytypes :: Map Text Text
+ , tilesetPropertytypes :: Maybe (Map Text Text)
-- ^ String key-value pairs
, tilesetMargin :: Int
-- ^ Buffer between image edge and first tile (pixels)
, tilesetSpacing :: Int
-- ^ Spacing between adjacent tiles in image (pixels)
- , tilesetTileproperties :: Map GlobalId (Map Text Text)
+ , tilesetTileproperties :: Maybe (Map GlobalId (Map Text Text))
-- ^ Per-tile properties, indexed by gid as string
- , tilesetTerrains :: Vector Terrain
+ , tilesetTerrains :: Maybe (Vector Terrain)
-- ^ Array of Terrains (optional)
, tilesetColumns :: Int
-- ^ The number of tile columns in the tileset
, tilesetTilecount :: Int
-- ^ The number of tiles in this tileset
- , tilesetTiles :: Map LocalId Tile
+ , tilesetTiles :: Maybe (Vector Tile)
-- ^ Tiles (optional)
+ , tilesetTransparentcolor :: Maybe String
} deriving (Eq, Generic, Show)
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value)
deriving (Show, Eq, Generic, FromJSON)
-parseTiles :: A.Object -> Parser (Map LocalId Tile)
-parseTiles o = do
- TransitiveTilesetMap localId2Value <- o .: "tiles"
- localIdAndTiles <- forM (M.toList localId2Value) $ \(lid, val) -> do
- tile <- parseJSON val
- return (lid, tile{ tileId = lid })
- return $ M.fromList localIdAndTiles
-
instance FromJSON Tileset where
- parseJSON (A.Object o) = Tileset <$> o .: "firstgid"
- <*> o .: "image"
- <*> o .: "name"
- <*> o .: "tilewidth"
- <*> o .: "tileheight"
- <*> o .: "imagewidth"
- <*> o .: "imageheight"
- <*> (o .: "properties" <|> pure mempty)
- <*> (o .: "propertytypes" <|> pure mempty)
- <*> o .: "margin"
- <*> o .: "spacing"
- <*> (o .: "tileproperties" <|> pure mempty)
- <*> (o .: "terrains" <|> pure mempty)
- <*> o .: "columns"
- <*> o .: "tilecount"
- <*> (parseTiles o <|> pure mempty)
- parseJSON invalid = typeMismatch "Tileset" invalid
+ parseJSON = genericParseJSON (aesonOptions 7)
instance ToJSON Tileset where
- toJSON Tileset{..} = object [ "firstgid" .= tilesetFirstgid
- , "image" .= tilesetImage
- , "name" .= tilesetName
- , "tilewidth" .= tilesetTilewidth
- , "tileheight" .= tilesetTileheight
- , "imagewidth" .= tilesetImagewidth
- , "imageheight" .= tilesetImageheight
- , "properties" .= tilesetProperties
- , "propertytypes" .= tilesetPropertytypes
- , "margin" .= tilesetMargin
- , "spacing" .= tilesetSpacing
- , "tileproperties" .= tilesetTileproperties
- , "terrains" .= tilesetTerrains
- , "columns" .= tilesetColumns
- , "tilecount" .= tilesetTilecount
- , "tiles" .= tilesetTiles
- ]
+ toJSON = genericToJSON (aesonOptions 7)
-- | The full monty.
-data Tiledmap = Tiledmap { tiledmapVersion :: Float
+data Tiledmap = Tiledmap { tiledmapVersion :: Float
-- ^ The JSON format version
- , tiledmapTiledversion :: String
+ , tiledmapTiledversion :: String
-- ^ The Tiled version used to save the file
- , tiledmapWidth :: Int
+ , tiledmapWidth :: Int
-- ^ Number of tile columns
- , tiledmapHeight :: Int
+ , tiledmapHeight :: Int
-- ^ Number of tile rows
- , tiledmapTilewidth :: Double
+ , tiledmapTilewidth :: Double
-- ^ Map grid width.
- , tiledmapTileheight :: Double
+ , tiledmapTileheight :: Double
-- ^ Map grid height.
- , tiledmapOrientation :: String
+ , tiledmapOrientation :: String
-- ^ Orthogonal, isometric, or staggered
- , tiledmapLayers :: Vector Layer
+ , tiledmapLayers :: Vector Layer
-- ^ Array of Layers
- , tiledmapTilesets :: Vector Tileset
+ , tiledmapTilesets :: Vector Tileset
-- ^ Array of Tilesets
- , tiledmapBackgroundcolor :: Maybe String
+ , tiledmapBackgroundcolor :: Maybe String
-- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional)
- , tiledmapRenderorder :: String
+ , tiledmapRenderorder :: String
-- ^ Rendering direction (orthogonal maps only)
- , tiledmapProperties :: [Property]
+ , tiledmapProperties :: Maybe [Property]
-- ^ String key-value pairs
- , tiledmapNextobjectid :: Int
+ , tiledmapNextobjectid :: Int
-- ^ Auto-increments for each placed object
+ , tiledmapCompressionLevel :: Maybe Int
+ , tiledmapInfinite :: Bool
+ , tiledmapNextlayerid :: Maybe Int
+ , tiledmapHexsidelength :: Maybe Int
+ , tiledmapStaggerindex :: Maybe String
+ , tiledmapType :: String
} deriving (Eq, Generic, Show)
instance FromJSON Tiledmap where
- parseJSON (A.Object o) = Tiledmap <$> o .: "version"
- <*> o .: "tiledversion"
- <*> o .: "width"
- <*> o .: "height"
- <*> o .: "tilewidth"
- <*> o .: "tileheight"
- <*> o .: "orientation"
- <*> o .: "layers"
- <*> o .: "tilesets"
- <*> (o .: "backgroundcolor" <|> pure Nothing)
- <*> o .: "renderorder"
- <*> (o .:? "properties" <&> fromMaybe [])
- <*> o .: "nextobjectid"
- parseJSON invalid = typeMismatch "Tiledmap" invalid
-
+ parseJSON = genericParseJSON (aesonOptions 8)
instance ToJSON Tiledmap where
- toJSON Tiledmap{..} = object [ "version" .= tiledmapVersion
- , "tiledversion" .= tiledmapTiledversion
- , "width" .= tiledmapWidth
- , "height" .= tiledmapHeight
- , "tilewidth" .= tiledmapTilewidth
- , "tileheight" .= tiledmapTileheight
- , "orientation" .= tiledmapOrientation
- , "layers" .= tiledmapLayers
- , "tilesets" .= tiledmapTilesets
- , "backgroundcolor" .= tiledmapBackgroundcolor
- , "renderorder" .= tiledmapRenderorder
- , "properties" .= tiledmapProperties
- , "nextobjectid" .= tiledmapNextobjectid
- ]
+ toJSON = genericToJSON (aesonOptions 8)
+
+
+class HasProperties a where
+ getProperties :: a -> [Property]
+
+instance HasProperties Layer where
+ getProperties = fromMaybe [] . layerProperties
+
+instance HasProperties Tileset where
+ getProperties = fromMaybe [] . tilesetProperties
+
+
data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 15:10:50 +0000