{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} -- | 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 Data.Tiled where import Universum import Control.Exception (IOException) import Data.Aeson hiding (Object) import qualified Data.Aeson as A import Data.Aeson.TH (deriveJSON) import Data.Aeson.Types (typeMismatch) import Data.Tiled.TH -- | A globally indexed identifier. newtype GlobalId = GlobalId { unGlobalId :: Int } deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData) -- | A locally indexed identifier. newtype LocalId = LocalId { unLocalId :: Int } deriving newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData) type Color = Text -- | A custom tiled property, which just has a name and a value. data Property = Property Text PropertyValue deriving (Eq, Generic, Show, NFData) -- | 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, NFData) instance IsString PropertyValue where fromString s = StrProp (toText 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, NFData) -- | all kinds of objects that can occur in object layers, even -- | those that we don't want to allow. data Object = ObjectRectangle { objectId :: Int , objectName :: Maybe String , objectProperties :: Maybe (Vector Property) , objectVisible :: Maybe Bool , objectX :: Double , objectY :: Double , objectRotation :: Double , objectGid :: Maybe GlobalId , objectWidth :: Maybe Double , objectHeight :: Maybe Double , objectEllipse :: Maybe Bool , objectPoint :: 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 :: Maybe Double , objectHeight :: Maybe 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 :: Maybe Double , objectHeight :: Maybe Double , objectType :: Text , 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 :: Maybe Double , objectHeight :: Maybe Double , objectEllipse :: Maybe Bool , objectType :: Text } deriving (Eq, Generic, Show, NFData) 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, NFData) data Terrain = Terrain { terrainName :: String -- ^ Name of terrain , terrainTile :: LocalId -- ^ Local ID of tile representing terrain } deriving (Eq, Generic, Show, NFData) 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, NFData) 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, NFData) data Tileset = Tileset { tilesetFirstgid :: GlobalId -- ^ GID corresponding to the first tile in the set , tilesetImage :: Maybe 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, NFData) newtype TransitiveTilesetMap = TransitiveTilesetMap (Map LocalId Value) deriving newtype (Show, Eq, FromJSON) -- | 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, NFData) $(deriveJSON (aesonOptions 5) ''Point) $(deriveJSON (aesonOptions 6) ''Object) $(deriveJSON (aesonOptions 5) ''Layer) $(deriveJSON (aesonOptions 4) ''Tile) $(deriveJSON (aesonOptions 7) ''Tileset) $(deriveJSON (aesonOptions 8) ''Tiledmap) -- | Load a Tiled map from the given 'FilePath'. loadTiledmap :: FilePath -> IO (Either String Tiledmap) loadTiledmap path = catch (eitherDecodeFileStrict' path >>= \case Left err -> pure $ Left err Right !tiledmap -> evaluateNF tiledmap <&> Right) (\(_ :: IOException) -> pure (Left $ "Failed to read this file."))