aeson-tiled (empty) → 0.0.0.1
raw patch · 7 files changed
+491/−0 lines, 7 filesdep +aesondep +aeson-tileddep +basesetup-changed
Dependencies added: aeson, aeson-tiled, base, bytestring, containers, hspec, text, vector
Files
- LICENSE +30/−0
- README.md +8/−0
- Setup.hs +2/−0
- aeson-tiled.cabal +50/−0
- app/Main.hs +6/−0
- src/Data/Aeson/Tiled.hs +371/−0
- test/Spec.hs +24/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Schell Scivally (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Schell Scivally nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,8 @@+# aeson-tiled+[](https://travis-ci.org/schell/aeson-tiled)+[](https://hackage.haskell.org/package/aeson-tiled)+`aeson-tiled` is the spiritual successor to `htiled`. `htiled` uses `hxt` which relies+too heavily on Arrows and is rather hard to work with. Tiled's json export+supports 100% of Tiled's features, so there doesn't seem to be much of a+point to maintaining a large Arrows-based project when writing Aeson instances+for Tiled types is much easier. Hence this project!
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ aeson-tiled.cabal view
@@ -0,0 +1,50 @@+name: aeson-tiled+version: 0.0.0.1+synopsis: Aeson instances for the Tiled map editor.+description: The mighty Tiled 2d map editor is an open source+ app for creating tile based level maps. This package provides+ types and aeson instances to read Tiled json files.+homepage: https://github.com/schell/aeson-tiled#readme+license: BSD3+license-file: LICENSE+author: Schell Scivally+maintainer: schell@takt.com+copyright: Copyright: (c) 2017 Schell Scivally+category: Game+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Data.Aeson.Tiled+ build-depends: base >= 4.7 && < 5+ , bytestring >= 0.10+ , aeson >= 1.1+ , containers >= 0.5+ , text >= 1.2+ , vector >= 0.12+ default-language: Haskell2010++executable aeson-tiled-exe+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends: base+ , aeson-tiled+ default-language: Haskell2010++test-suite aeson-tiled-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , aeson >= 1.1+ , aeson-tiled+ , hspec+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/schell/aeson-tiled
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Data.Aeson.Tiled++main :: IO ()+main = print =<< loadTiledmap "example.json"
+ src/Data/Aeson/Tiled.hs view
@@ -0,0 +1,371 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# 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/+module Data.Aeson.Tiled+ ( -- * Tiled map editor types, their aeson instances and map loading+ module Data.Aeson.Tiled+ -- * Re-exports for working with Tiled types+ , module Data.Map+ , module Data.Vector+ ) where++import Control.Applicative ((<|>))+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.Lazy.Char8 as C8+import Data.Map (Map)+import qualified Data.Map as M+import Data.Text (Text)+import Data.Vector (Vector)+import GHC.Generics (Generic)+++-- | A globally indexed identifier.+newtype GlobalId = GlobalId { unGlobalId :: Int }+ deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)+++-- | A locally indexed identifier.+newtype LocalId = LocalId { unLocalId :: Int }+ deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)+++data Object = Object { objectId :: Int+ -- ^ Incremental id - unique across all objects+ , objectWidth :: Int+ -- ^ Width in pixels. Ignored if using a gid.+ , objectHeight :: Int+ -- ^ Height in pixels. Ignored if using a gid.+ , objectName :: String+ -- ^ String assigned to name field in editor+ , objectType :: String+ -- ^ String assigned to type field in editor+ , objectProperties :: Map Text Text+ -- ^ String key-value pairs+ , objectVisible :: Bool+ -- ^ Whether object is shown in editor.+ , objectX :: Int+ -- ^ x coordinate in pixels+ , objectY :: Int+ -- ^ y coordinate in pixels+ , objectRotation :: Float+ -- ^ Angle in degrees clockwise+ , objectGid :: GlobalId+ -- ^ GID, only if object comes from a Tilemap+ , objectEllipse :: Bool+ -- ^ Used to mark an object as an ellipse+ , objectPolygon :: Vector (Int, Int)+ -- ^ A list of x,y coordinates in pixels+ , objectPolyline :: Vector (Int, Int)+ -- ^ A list of x,y coordinates in pixels+ , objectText :: Map Text Text+ -- ^ String key-value pairs+ } deriving (Eq, Generic, Show)++instance FromJSON Object where+ parseJSON (A.Object o) = Object <$> o .: "id"+ <*> o .: "width"+ <*> o .: "height"+ <*> o .: "name"+ <*> o .: "type"+ <*> o .: "properties"+ <*> o .: "visible"+ <*> o .: "x"+ <*> o .: "y"+ <*> o .: "rotation"+ <*> o .: "gid"+ <*> o .: "ellipse"+ <*> o .: "polygon"+ <*> o .: "polyline"+ <*> o .: "text"+ parseJSON invalid = typeMismatch "Object" invalid++instance ToJSON Object where+ toJSON Object{..} = 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" .= objectPolygon+ , "polyline" .= objectPolyline+ , "text" .= objectText+ ]+++data Layer = Layer { layerWidth :: Int+ -- ^ Column count. Same as map width for fixed-size maps.+ , layerHeight :: Int+ -- ^ Row count. Same as map height for fixed-size maps.+ , layerName :: String+ -- ^ Name assigned to this layer+ , layerType :: String+ -- ^ “tilelayer”, “objectgroup”, or “imagelayer”+ , layerVisible :: Bool+ -- ^ Whether layer is shown or hidden in editor+ , layerX :: Int+ -- ^ Horizontal layer offset in tiles. Always 0.+ , layerY :: Int+ -- ^ 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 :: Map Text Text+ -- ^ string key-value pairs.+ , layerOpacity :: Float+ -- ^ Value between 0 and 1+ , layerDraworder :: String+ -- ^ “topdown” (default) or “index”. objectgroup only.+ } 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" <|> pure Nothing)+ <*> (o .: "properties" <|> pure mempty)+ <*> o .: "opacity"+ <*> (o .: "draworder" <|> pure "topdown")+ parseJSON invalid = typeMismatch "Layer" invalid++instance ToJSON Layer where+ toJSON Layer{..} = 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+ ]+++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 :: LocalId+ , tileProperties :: Map Text Text+ , 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++instance ToJSON Tile where+ toJSON Tile{..} = object [ "properties" .= tileProperties+ , "image" .= tileImage+ , "objectGroup" .= tileObjectGroup+ , "animation" .= tileAnimation+ ]+++data Tileset = Tileset { tilesetFirstgid :: GlobalId+ -- ^ GID corresponding to the first tile in the set+ , tilesetImage :: String+ -- ^ Image used for tiles in this set+ , tilesetName :: String+ -- ^ 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 :: Map Text Text+ -- ^ String key-value pairs+ , tilesetPropertytypes :: 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)+ -- ^ Per-tile properties, indexed by gid as string+ , tilesetTerrains :: 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+ -- ^ Tiles (optional)+ } 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++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+ ]+++-- | The full monty.+data Tiledmap = Tiledmap { tiledmapVersion :: Float+ -- ^ The JSON format version+ , tiledmapTiledversion :: String+ -- ^ The Tiled version used to save the file+ , tiledmapWidth :: Int+ -- ^ Number of tile columns+ , tiledmapHeight :: Int+ -- ^ Number of tile rows+ , tiledmapTilewidth :: Int+ -- ^ Map grid width.+ , tiledmapTileheight :: Int+ -- ^ 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 :: Map Text Text+ -- ^ String key-value pairs+ , tiledmapNextobjectid :: Int+ -- ^ Auto-increments for each placed object+ } 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" <|> pure mempty)+ <*> o .: "nextobjectid"+ parseJSON invalid = typeMismatch "Tiledmap" invalid++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+ ]+++-- | Load a Tiled map from the given 'FilePath'.+loadTiledmap :: FilePath -> IO (Either String Tiledmap)+loadTiledmap = fmap eitherDecode . C8.readFile
+ test/Spec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE LambdaCase #-}+import Data.Aeson (encode, eitherDecode)+import Test.Hspec+import Control.Monad (forM_)++import Data.Aeson.Tiled++files :: [FilePath]+files = [ "maps/example.json"+ , "maps/test1.json"+ , "maps/test2.json"+ , "maps/test3.json"+ , "maps/test4.json"+ ]++main :: IO ()+main = hspec $ forM_ files $ \file ->+ describe ("With " ++ show file) $+ it "loading and encoding and decoding should end up with the same Tiledmap" $+ loadTiledmap file >>= \case+ Right tm -> do+ let bs = encode tm+ eitherDecode bs `shouldBe` Right tm+ _ -> fail $ "Could not decode Tiledmap from " ++ show file