From 8a201e8658c9365d301a7cda9077ddf005b014c9 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Mon, 28 Feb 2022 00:39:54 +0100 Subject: separate tiled modules out into own package --- lib/CheckDir.hs | 2 +- lib/CheckMap.hs | 2 +- lib/LayerData.hs | 2 +- lib/LintWriter.hs | 2 +- lib/Properties.hs | 4 +- lib/Tiled.hs | 395 ------------------------------------------ lib/TiledAbstract.hs | 66 -------- lib/Util.hs | 2 +- package.yaml | 10 ++ tiled/Data/Tiled.hs | 396 +++++++++++++++++++++++++++++++++++++++++++ tiled/Data/Tiled/Abstract.hs | 66 ++++++++ walint.cabal | 23 ++- 12 files changed, 500 insertions(+), 470 deletions(-) delete mode 100644 lib/Tiled.hs delete mode 100644 lib/TiledAbstract.hs create mode 100644 tiled/Data/Tiled.hs create mode 100644 tiled/Data/Tiled/Abstract.hs diff --git a/lib/CheckDir.hs b/lib/CheckDir.hs index be23747..93b6345 100644 --- a/lib/CheckDir.hs +++ b/lib/CheckDir.hs @@ -40,7 +40,7 @@ import System.FilePath (splitPath, ()) import qualified System.FilePath as FP import System.FilePath.Posix (takeDirectory) import Text.Dot (showDot) -import Tiled (Tiledmap) +import Data.Tiled (Tiledmap) import Types (Dep (Local, LocalMap), Hint (Hint), Level (..), hintLevel) import Util (PrettyPrint (prettyprint)) diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 3ac03bd..0b5b58a 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -32,7 +32,7 @@ import LintWriter (LintResult, invertLintResult, runLintWriter) import Properties (checkLayer, checkMap, checkTileset) import System.FilePath (takeFileName) -import Tiled (Layer (layerLayers, layerName), +import Data.Tiled (Layer (layerLayers, layerName), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), loadTiledmap) diff --git a/lib/LayerData.hs b/lib/LayerData.hs index 6956c92..46d6449 100644 --- a/lib/LayerData.hs +++ b/lib/LayerData.hs @@ -8,7 +8,7 @@ import Control.Monad.Zip (mzipWith) import Data.Set (insert) import Data.Vector (maximum, uncons) import qualified Text.Show as TS -import Tiled (GlobalId (unGlobalId), Layer (..)) +import Data.Tiled (GlobalId (unGlobalId), Layer (..)) import Util (PrettyPrint (..)) -- | A collision between two layers of the given names. diff --git a/lib/LintWriter.hs b/lib/LintWriter.hs index d0c6c4e..b55b16e 100644 --- a/lib/LintWriter.hs +++ b/lib/LintWriter.hs @@ -48,7 +48,7 @@ import Universum import Badges (Badge) import Data.Map (fromListWith) import LintConfig (LintConfig') -import TiledAbstract (HasName (getName)) +import Data.Tiled.Abstract (HasName (getName)) import Types (Dep, Hint, Level (..), Lint (..), hint, lintsToHints) diff --git a/lib/Properties.hs b/lib/Properties.hs index 5d9c094..1ba5faa 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -18,10 +18,10 @@ import Universum hiding (intercalate, isPrefixOf) import Data.Text (intercalate, isInfixOf, isPrefixOf) import qualified Data.Text as T import qualified Data.Vector as V -import Tiled (Layer (..), Object (..), Property (..), +import Data.Tiled (Layer (..), Object (..), Property (..), PropertyValue (..), Tile (..), Tiledmap (..), Tileset (..)) -import TiledAbstract (HasName (..), HasProperties (..), +import Data.Tiled.Abstract (HasName (..), HasProperties (..), HasTypeName (..), IsProperty (..)) import Util (layerIsEmpty, mkProxy, naiveEscapeHTML, prettyprint) 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 diff --git a/lib/TiledAbstract.hs b/lib/TiledAbstract.hs deleted file mode 100644 index 9fd2df0..0000000 --- a/lib/TiledAbstract.hs +++ /dev/null @@ -1,66 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module TiledAbstract where - -import Universum - -import qualified Data.Vector as V -import Tiled (Layer (..), Object (..), Property (..), - PropertyValue (..), Tile (..), Tiledmap (..), - Tileset (..)) - -class HasProperties a where - getProperties :: a -> [Property] - adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a - -instance HasProperties Layer where - getProperties = maybeToMonoid . layerProperties - adjustProperties f layer = layer - { layerProperties = f (getProperties layer) } - -instance HasProperties Tileset where - getProperties = maybeToMonoid . tilesetProperties - adjustProperties f tileset = tileset - { tilesetProperties = f (getProperties tileset) } - -instance HasProperties Tile where - getProperties = V.toList . maybeToMonoid . tileProperties - adjustProperties f tile = tile - { tileProperties = (fmap V.fromList . f) (getProperties tile) } - -instance HasProperties Object where - getProperties = V.toList . maybeToMonoid . objectProperties - adjustProperties f obj = obj - { objectProperties = (fmap V.fromList . f) (getProperties obj) } - -instance HasProperties Tiledmap where - getProperties = maybeToMonoid . tiledmapProperties - adjustProperties f tiledmap = tiledmap - { tiledmapProperties = f (getProperties tiledmap) } - -class HasTypeName a where - typeName :: Proxy a -> Text -instance HasTypeName Layer where - typeName _ = "layer" -instance HasTypeName Tileset where - typeName _ = "tileset" -instance HasTypeName Property where - typeName _ = "property" - -class HasName a where - getName :: a -> Text -instance HasName Layer where - getName = layerName -instance HasName Tileset where - getName = tilesetName -instance HasName Property where - getName (Property n _) = n - -class IsProperty a where - asProperty :: a -> PropertyValue -instance IsProperty PropertyValue where - asProperty = id - {-# INLINE asProperty #-} -instance IsProperty Text where - asProperty = StrProp - {-# INLINE asProperty #-} diff --git a/lib/Util.hs b/lib/Util.hs index f935e78..ccd2ef3 100644 --- a/lib/Util.hs +++ b/lib/Util.hs @@ -17,7 +17,7 @@ import Universum import Data.Aeson as Aeson import qualified Data.Set as S import qualified Data.Text as T -import Tiled (Layer (layerData), PropertyValue (..), +import Data.Tiled (Layer (layerData), PropertyValue (..), Tileset (tilesetName), layerName, mkTiledId) mkProxy :: a -> Proxy a diff --git a/package.yaml b/package.yaml index f9498d6..53ef4c2 100644 --- a/package.yaml +++ b/package.yaml @@ -15,10 +15,20 @@ dependencies: - bytestring - text +internal-libraries: + tiled: + source-dirs: 'tiled' + dependencies: + - vector + exposed-modules: + - Data.Tiled + - Data.Tiled.Abstract + library: source-dirs: 'lib' dependencies: - containers + - tiled - text - vector - transformers diff --git a/tiled/Data/Tiled.hs b/tiled/Data/Tiled.hs new file mode 100644 index 0000000..046a080 --- /dev/null +++ b/tiled/Data/Tiled.hs @@ -0,0 +1,396 @@ +{-# 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 Data.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 + deriving Show + +-- | 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 diff --git a/tiled/Data/Tiled/Abstract.hs b/tiled/Data/Tiled/Abstract.hs new file mode 100644 index 0000000..4b2e15d --- /dev/null +++ b/tiled/Data/Tiled/Abstract.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Tiled.Abstract where + +import Universum + +import qualified Data.Vector as V +import Data.Tiled (Layer (..), Object (..), Property (..), + PropertyValue (..), Tile (..), Tiledmap (..), + Tileset (..)) + +class HasProperties a where + getProperties :: a -> [Property] + adjustProperties :: ([Property] -> Maybe [Property]) -> a -> a + +instance HasProperties Layer where + getProperties = maybeToMonoid . layerProperties + adjustProperties f layer = layer + { layerProperties = f (getProperties layer) } + +instance HasProperties Tileset where + getProperties = maybeToMonoid . tilesetProperties + adjustProperties f tileset = tileset + { tilesetProperties = f (getProperties tileset) } + +instance HasProperties Tile where + getProperties = V.toList . maybeToMonoid . tileProperties + adjustProperties f tile = tile + { tileProperties = (fmap V.fromList . f) (getProperties tile) } + +instance HasProperties Object where + getProperties = V.toList . maybeToMonoid . objectProperties + adjustProperties f obj = obj + { objectProperties = (fmap V.fromList . f) (getProperties obj) } + +instance HasProperties Tiledmap where + getProperties = maybeToMonoid . tiledmapProperties + adjustProperties f tiledmap = tiledmap + { tiledmapProperties = f (getProperties tiledmap) } + +class HasTypeName a where + typeName :: Proxy a -> Text +instance HasTypeName Layer where + typeName _ = "layer" +instance HasTypeName Tileset where + typeName _ = "tileset" +instance HasTypeName Property where + typeName _ = "property" + +class HasName a where + getName :: a -> Text +instance HasName Layer where + getName = layerName +instance HasName Tileset where + getName = tilesetName +instance HasName Property where + getName (Property n _) = n + +class IsProperty a where + asProperty :: a -> PropertyValue +instance IsProperty PropertyValue where + asProperty = id + {-# INLINE asProperty #-} +instance IsProperty Text where + asProperty = StrProp + {-# INLINE asProperty #-} diff --git a/walint.cabal b/walint.cabal index 94d79f5..0bc387a 100644 --- a/walint.cabal +++ b/walint.cabal @@ -28,8 +28,6 @@ library LintWriter Paths Properties - Tiled - TiledAbstract Uris Paths_walint hs-source-dirs: @@ -53,12 +51,33 @@ library , regex-tdfa , text , text-metrics + , tiled , transformers , universum , uri-encode , vector default-language: Haskell2010 +library tiled + exposed-modules: + Data.Tiled + Data.Tiled.Abstract + other-modules: + Paths_walint + hs-source-dirs: + tiled + default-extensions: + NoImplicitPrelude + ghc-options: -Wall -Wno-name-shadowing -Wno-unticked-promoted-constructors + build-depends: + aeson + , base + , bytestring + , text + , universum + , vector + default-language: Haskell2010 + executable walint main-is: Main.hs other-modules: -- cgit v1.2.3