summaryrefslogtreecommitdiff
path: root/lib/Tiled.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Tiled.hs')
-rw-r--r--lib/Tiled.hs395
1 files changed, 0 insertions, 395 deletions
diff --git a/lib/Tiled.hs b/lib/Tiled.hs
deleted file mode 100644
index 3162dfd..0000000
--- a/lib/Tiled.hs
+++ /dev/null
@@ -1,395 +0,0 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DerivingStrategies #-}
-{-# 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 Universum
-
--- TODO: what ever are these aeson imports
-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)
-
-
--- | 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 newtype (Ord, Eq, Enum, Num, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey, NFData)
-
-mkTiledId :: Int -> GlobalId
-mkTiledId i = GlobalId { unGlobalId = i }
-
--- | 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)
-
-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 = 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)
-
-
-
-
-
-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, NFData)
-
-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, 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)
-
-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 :: 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)
-
-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, NFData)
-
-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