Select Git revision
Tiled.hs 16.49 KiB
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | 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/
module Tiled where
import Control.Exception (try)
import Control.Exception.Base (SomeException)
import Data.Aeson hiding (Object)
import qualified Data.Aeson as A
import Data.Aeson.Types (typeMismatch)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LB
import Data.Char (toLower)
import Data.Map (Map)
import Data.String (IsString (fromString))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Vector (Vector)
import GHC.Generics (Generic)
-- | options for Aeson's generic encoding and parsing functions
aesonOptions :: Int -> Options
aesonOptions l = defaultOptions
{ omitNothingFields = True
, rejectUnknownFields = True
-- can't be bothered to do a nicer prefix strip
, fieldLabelModifier = drop l . map toLower
, sumEncoding = UntaggedValue
}
-- | A globally indexed identifier.
newtype GlobalId = GlobalId { unGlobalId :: Int }
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
mkTiledId :: Int -> GlobalId
mkTiledId i = GlobalId { unGlobalId = i }
-- | A locally indexed identifier.
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.
data Property = Property Text PropertyValue
deriving (Eq, Generic, Show)
-- | The value of a custom tiled property.
-- It is strongly typed via a tag in the json representation,
-- and needs a custom ToJSON and FromJSON instance because of that.
data PropertyValue = StrProp Text | BoolProp Bool | IntProp Int | FloatProp Float
deriving (Eq, Generic, Show)
instance IsString PropertyValue where
fromString s = StrProp (T.pack s)
instance FromJSON Property where
parseJSON (A.Object o) = do
name <- o .: "name"
o .: "type" >>= \case
A.String "string" -> do
val <- o .: "value"
pure $ Property name (StrProp val)
A.String "bool" -> do
val <- o .: "value"
pure $ Property name (BoolProp val)
A.String "int" -> do
val <- o .: "value"
pure $ Property name (IntProp val)
A.String "float" -> do
val <- o .: "value"
pure $ Property name (FloatProp val)
ty -> fail $ "properties can only have types string, int, bool, but encountered type" <> show ty
parseJSON invalid = typeMismatch "Property" invalid
instance ToJSON Property where
toJSON (Property name val) = case val of
StrProp str -> object
[ "type" .= A.String "string"
, "name" .= name
, "value" .= str
]
BoolProp bool -> object
[ "type" .= A.String "bool"
, "name" .= name
, "value" .= bool
]
IntProp int -> object
[ "type" .= A.String "int"
, "name" .= name
, "value" .= int
]
FloatProp float -> object
[ "type" .= A.String "float"
, "name" .= name
, "value" .= float
]
data Point = Point { pointX :: Double
, pointY :: Double
} deriving (Eq, Generic, Show)
instance FromJSON Point where
parseJSON = genericParseJSON (aesonOptions 5)
instance ToJSON Point where
toJSON = genericToJSON (aesonOptions 5)
-- | all kinds of objects that can occur in object layers, even
-- | those that we don't want to allow.
data Object = ObjectPoint
{ objectId :: Int
, objectName :: Maybe String
, objectProperties :: Maybe (Vector Property)
, objectVisible :: Maybe Bool
, objectX :: Double
, objectY :: Double
, objectHeight :: Double
, objectWidth :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
, objectType :: Text
, objectPoint :: Bool
}
| ObjectRectangle
{ objectId :: Int , objectName :: Maybe String
, objectProperties :: Maybe (Vector Property)
, objectVisible :: Maybe Bool
, objectX :: Double
, objectY :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
, objectWidth :: Double
, objectHeight :: Double
, objectEllipse :: Maybe Bool
, objectType :: Text
}
| ObjectPolygon
{ objectId :: Int
, objectName :: Maybe String
, objectProperties :: Maybe (Vector Property)
, objectVisible :: Maybe Bool
, objectX :: Double
, objectY :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
, objectWidth :: Double
, objectHeight :: Double
, objectType :: Text
, objectPolygon :: Vector Point
}
| ObjectPolyline
{ objectId :: Int
, objectName :: Maybe String
, objectProperties :: Maybe (Vector Property)
, objectVisible :: Maybe Bool
, objectX :: Double
, objectY :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
, objectWidth :: Double
, objectType :: Text
, objectHeight :: Double
, objectPolyline :: Vector Point
}
| ObjectText
{ objectId :: Int
, objectName :: Maybe String
, objectProperties :: Maybe (Vector Property)
, objectVisible :: Maybe Bool
, objectX :: Double
, objectY :: Double
, objectRotation :: Double
, objectGid :: Maybe GlobalId
, objectText :: A.Value
, objectWidth :: Double
, objectHeight :: Double
, objectEllipse :: Maybe Bool
, objectType :: Text
} deriving (Eq, Generic, Show)
instance FromJSON Object where
parseJSON = genericParseJSON (aesonOptions 6)
instance ToJSON Object where
toJSON = genericToJSON (aesonOptions 6)
data Layer = Layer { layerWidth :: Maybe Double
-- ^ Column count. Same as map width for fixed-size maps.
, layerHeight :: Maybe Double
-- ^ Row count. Same as map height for fixed-size maps. , layerName :: Text
-- ^ Name assigned to this layer
, layerType :: Text
-- ^ “tilelayer”, “objectgroup”, or “imagelayer”
, layerVisible :: Bool
-- ^ Whether layer is shown or hidden in editor
, layerX :: Double
-- ^ Horizontal layer offset in tiles. Always 0.
, layerY :: Double
-- ^ Vertical layer offset in tiles. Always 0.
, layerData :: Maybe (Vector GlobalId)
-- ^ Array of GIDs. tilelayer only.
, layerObjects :: Maybe (Vector Object)
-- ^ Array of Objects. objectgroup only.
, layerProperties :: Maybe [Property]
-- ^ string key-value pairs.
, layerOpacity :: Float
-- ^ Value between 0 and 1
, layerDraworder :: Maybe String
-- ^ “topdown” (default) or “index”. objectgroup only.
, layerId :: Int
, layerOffsetx :: Maybe Float
, layerOffsety :: Maybe Float
, layerParallaxx :: Maybe Float
, layerParallaxy :: Maybe Float
, layerTintColor :: Maybe Color
, layerTransparentColor :: Maybe Color
, layerImage :: Maybe Text
, layerLayers :: Maybe [Layer]
, layerStartX :: Maybe Int
, layerStartY :: Maybe Int
, layerColor :: Maybe Color
} deriving (Eq, Generic, Show)
instance FromJSON Layer where
parseJSON = genericParseJSON (aesonOptions 5)
instance ToJSON Layer where
toJSON = genericToJSON (aesonOptions 5)
data Terrain = Terrain { terrainName :: String
-- ^ Name of terrain
, terrainTile :: LocalId
-- ^ Local ID of tile representing terrain
} deriving (Eq, Generic, Show)
instance FromJSON Terrain where
parseJSON (A.Object o) = Terrain <$> o .: "name"
<*> o .: "tile"
parseJSON invalid = typeMismatch "Terrain" invalid
instance ToJSON Terrain where
toJSON Terrain{..} = object [ "name" .= terrainName
, "tile" .= terrainTile
]
data Frame = Frame { frameDuration :: Int
, frameTileId :: LocalId
} deriving (Eq, Generic, Show)
instance FromJSON Frame where
parseJSON (A.Object o) = Frame <$> o .: "duration"
<*> o .: "tileid"
parseJSON invalid = typeMismatch "Frame" invalid
instance ToJSON Frame where
toJSON Frame{..} = object [ "duration" .= frameDuration
, "tileid" .= frameTileId ]
data Tile = Tile { tileId :: Int
, tileProperties :: Maybe (Vector Property)
, tileImage :: Maybe Value
, tileObjectGroup :: Maybe Value
, tileAnimation :: Maybe (Vector Frame)
, tileImageheight :: Maybe Int
, tileImagewidth :: Maybe Int
, tileProbability :: Maybe Float
, tileType :: Maybe Text
, tileTerrain :: Maybe [Int]
} deriving (Eq, Generic, Show)
instance FromJSON Tile where
parseJSON = genericParseJSON (aesonOptions 4)
instance ToJSON Tile where
toJSON = genericToJSON (aesonOptions 4)
data Tileset = Tileset { tilesetFirstgid :: GlobalId
-- ^ GID corresponding to the first tile in the set
, tilesetImage :: Text
-- ^ Image used for tiles in this set
, tilesetName :: Text
-- ^ Name given to this tileset
, tilesetTilewidth :: Int
-- ^ Maximum width of tiles in this set
, tilesetTileheight :: Int
-- ^ Maximum height of tiles in this set
, tilesetImagewidth :: Int
-- ^ Width of source image in pixels
, tilesetImageheight :: Int
-- ^ Height of source image in pixels
, tilesetProperties :: Maybe [Property]
-- ^ String key-value pairs
, 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 :: Maybe (Map GlobalId (Map Text Text))
-- ^ Per-tile properties, indexed by gid as string
, 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 :: Maybe (Vector Tile)
-- ^ Tiles (optional)
, tilesetTransparentcolor :: Maybe Text
, tilesetEditorsettings :: Maybe Value
, tilesetBackgroundColor :: Maybe Text
, tilesetGrid :: Maybe Value
, tilesetSource :: Maybe Text
, tilesetTiledversion :: Maybe Text
, tilesetTileoffset :: Maybe Value
, tilesetTransformations :: Maybe Value
, tilesetVersion :: Maybe Value
, tilesetWangsets :: Maybe Value
, tilesetType :: Maybe Text
, tilesetFileName :: Maybe Text
} deriving (Eq, Generic, Show)
newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value) deriving (Show, Eq, Generic, FromJSON)
instance FromJSON Tileset where
parseJSON = genericParseJSON (aesonOptions 7)
instance ToJSON Tileset where
toJSON = genericToJSON (aesonOptions 7)
-- | The full monty.
data Tiledmap = Tiledmap { tiledmapVersion :: Value
-- ^ The JSON format version
, tiledmapTiledversion :: Maybe String
-- ^ The Tiled version used to save the file
, tiledmapWidth :: Int
-- ^ Number of tile columns
, tiledmapHeight :: Int
-- ^ Number of tile rows
, tiledmapTilewidth :: Double
-- ^ Map grid width.
, tiledmapTileheight :: Double
-- ^ Map grid height.
, tiledmapOrientation :: String
-- ^ Orthogonal, isometric, or staggered
, tiledmapLayers :: Vector Layer
-- ^ Array of Layers
, tiledmapTilesets :: Vector Tileset
-- ^ Array of Tilesets
, tiledmapBackgroundcolor :: Maybe String
-- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional)
, tiledmapRenderorder :: String
-- ^ Rendering direction (orthogonal maps only)
, tiledmapProperties :: Maybe [Property]
-- ^ String key-value pairs
, tiledmapNextobjectid :: Int
-- ^ Auto-increments for each placed object
, tiledmapCompressionLevel :: Maybe Int
, tiledmapInfinite :: Bool
, tiledmapNextlayerid :: Maybe Int
, tiledmapHexsidelength :: Maybe Int
, tiledmapStaggeraxis :: Maybe Text
, tiledmapStaggerindex :: Maybe String
, tiledmapType :: String
, tiledmapEditorsettings :: Maybe Value
} deriving (Eq, Generic, Show)
instance FromJSON Tiledmap where
parseJSON = genericParseJSON (aesonOptions 8)
instance ToJSON Tiledmap where
toJSON = genericToJSON (aesonOptions 8)
data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String
-- | Load a Tiled map from the given 'FilePath'.
loadTiledmap :: FilePath -> IO LoadResult
loadTiledmap path = do
res <- try (BS.readFile path)
pure $ case res of
Right file -> case eitherDecode . LB.fromStrict $ file of
Left err -> DecodeErr err
Right tiledmap -> Loaded tiledmap
Left (err :: SomeException) -> IOErr $ show err