From d2983b867a106ee0581d8dc1d8f413178cdd4027 Mon Sep 17 00:00:00 2001 From: stuebinm Date: Thu, 28 Oct 2021 13:28:55 +0200 Subject: make aeson instances agree with themselves This cleans up all the old rubble that came from the Tiled package I originally took from hackage. It now uses generics instead of implementing all the ToJSON and FromJSON instances by hand, and (deserialize . serialise) will now actually return a (semantically) equivalent json. It'll now also reject keys that it doesn't know, which required adding some in several places which the tiled package didn't know about (or which were introduced after it was originally written, dunno). Several more Maybes are required now, to represent the difference between e.g. empty lists and on set value, which does make the code slightly weirder in other places … --- lib/CheckMap.hs | 5 +- lib/Properties.hs | 21 ++--- lib/Tiled2.hs | 251 +++++++++++++++--------------------------------------- 3 files changed, 79 insertions(+), 198 deletions(-) (limited to 'lib') diff --git a/lib/CheckMap.hs b/lib/CheckMap.hs index 036f4e8..d7d45c0 100644 --- a/lib/CheckMap.hs +++ b/lib/CheckMap.hs @@ -23,7 +23,8 @@ import LintWriter (LintResult (..), LintWriter, askContext, filterLintLevel, lintToDep, resultToDeps, resultToLints, resultToOffers, runLintWriter) import Properties (checkLayerProperty, checkMap, checkTileset) -import Tiled2 (Layer (layerName, layerProperties), +import Tiled2 (HasProperties (getProperties), + Layer (layerName, layerProperties), LoadResult (..), Tiledmap (tiledmapLayers, tiledmapTilesets), Tileset (tilesetName), loadTiledmap) @@ -96,7 +97,7 @@ runLinter tiledmap depth = MapResult checkLayer :: LintWriter Layer checkLayer = do layer <- askContext - mapM_ checkLayerProperty (layerProperties layer) + mapM_ checkLayerProperty (getProperties layer) -- human-readable lint output, e.g. for consoles instance PrettyPrint (Level, MapResult) where diff --git a/lib/Properties.hs b/lib/Properties.hs index ed97355..1b0569d 100644 --- a/lib/Properties.hs +++ b/lib/Properties.hs @@ -8,10 +8,12 @@ module Properties (checkLayerProperty, checkMap, checkTileset) where import Control.Monad (unless, when) import Data.Text (Text, isPrefixOf) -import Tiled2 (Layer (..), Property (..), PropertyValue (..), +import Tiled2 (HasProperties (getProperties), Layer (..), + Property (..), PropertyValue (..), Tiledmap (..), Tileset (..)) import Util (layerIsEmpty, prettyprint) +import Data.Maybe (fromMaybe) import LintWriter (LintWriter, askContext, askFileDepth, complain, dependsOn, forbid, offersEntrypoint, suggest, warn) @@ -29,14 +31,14 @@ checkMap = do tiledmap <- askContext -- test other things - mapM_ checkMapProperty (tiledmapProperties tiledmap) + mapM_ checkMapProperty (fromMaybe [] $ tiledmapProperties tiledmap) -- some layers should exist hasLayerNamed "start" (const True) "The map must have one layer named \"start\"" hasLayerNamed "floorLayer" ((==) "objectgroup" . layerType) "The map must have one layer named \"floorLayer\" of type \"objectgroup\"" - hasLayer (flip containsProperty "exitUrl" . layerProperties) + hasLayer (flip containsProperty "exitUrl" . getProperties) "The map must contain at least one layer with the property \"exitUrl\" set" -- reject maps not suitable for workadventure @@ -82,7 +84,7 @@ checkTileset tileset = do -- TODO: check copyright! requireProperty "copyright" - mapM_ checkTilesetProperty (tilesetProperties tileset) + mapM_ checkTilesetProperty (fromMaybe [] $ tilesetProperties tileset) checkTilesetProperty :: Property -> LintWriter Tileset checkTilesetProperty p@(Property name value) = case name of @@ -182,15 +184,6 @@ checkLayerProperty p@(Property name _value) = case name of --------- Helper functions & stuff --------- -class HasProperties a where - getProperties :: a -> [Property] - -instance HasProperties Layer where - getProperties = layerProperties - -instance HasProperties Tileset where - getProperties = tilesetProperties - unlessHasProperty :: HasProperties a => Text -> LintWriter a -> LintWriter a unlessHasProperty name andthen = do layer <- askContext @@ -229,7 +222,7 @@ suggestProperty (Property name value) = -- | does this layer have the given property? -containsProperty :: [Property] -> Text -> Bool +containsProperty :: Foldable t => t Property -> Text -> Bool containsProperty props name = any (\(Property name' _) -> name' == name) props diff --git a/lib/Tiled2.hs b/lib/Tiled2.hs index 3fc8c31..45b8ad0 100644 --- a/lib/Tiled2.hs +++ b/lib/Tiled2.hs @@ -2,29 +2,27 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NamedFieldPuns #-} {-# 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/ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} module Tiled2 where -import Control.Applicative ((<|>)) import Control.Exception (try) import Control.Exception.Base (SomeException) -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 as BS import qualified Data.ByteString.Lazy as LB -import Data.Functor ((<&>)) +import Data.Char (toLower) import Data.Map (Map) -import qualified Data.Map as M import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Vector (Vector) @@ -32,6 +30,14 @@ import GHC.Exts (fromList, toList) import GHC.Generics (Generic) +-- | options for Aeson's generic encoding and parsing functions +aesonOptions :: Int -> Options +aesonOptions l = defaultOptions + { omitNothingFields = True + , rejectUnknownFields = True + , fieldLabelModifier = drop l . map toLower + } + -- | A globally indexed identifier. newtype GlobalId = GlobalId { unGlobalId :: Int } deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey) @@ -75,13 +81,6 @@ parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a parseDefault o s d = fromMaybe d <$> o .:? s -{-- | workadventure custom property -data Property = Property { propertyName :: Text - --, propertyType :: Text (unnecessary since always string) - , propertyValue :: Text - } deriving (Eq, Generic, Show) --} - data PropertyValue = StrProp Text | BoolProp Bool deriving (Eq, Generic, Show) data Property = Property Text PropertyValue @@ -145,46 +144,14 @@ data Object = Object { objectId :: Int } deriving (Eq, Generic, Show) instance FromJSON Object where - parseJSON (A.Object o) = Object <$> o .: "id" - <*> o .: "width" - <*> o .: "height" - <*> o .: "name" - <*> o .: "type" - <*> parseDefault o "properties" M.empty - <*> o .: "visible" - <*> o .: "x" - <*> o .: "y" - <*> o .: "rotation" - <*> o .:? "gid" - <*> parseDefault o "ellipse" False - <*> (fmap . fmap . fmap) fromXYPair (o .:? "polygon") - <*> (fmap . fmap . fmap) fromXYPair (o .:? "polyline") - <*> parseDefault o "text" M.empty - parseJSON invalid = typeMismatch "Object" invalid - + parseJSON = genericParseJSON (aesonOptions 6) instance ToJSON Object where - toJSON Object{..} = omitNulls $ - 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" .= (fmap . fmap) toXYPair objectPolygon - , "polyline" .= (fmap . fmap) toXYPair objectPolyline - , "text" .= objectText - ] + toJSON = genericToJSON (aesonOptions 6) -data Layer = Layer { layerWidth :: Double +data Layer = Layer { layerWidth :: Maybe Double -- ^ Column count. Same as map width for fixed-size maps. - , layerHeight :: Double + , layerHeight :: Maybe Double -- ^ Row count. Same as map height for fixed-size maps. , layerName :: Text -- ^ Name assigned to this layer @@ -200,44 +167,19 @@ data Layer = Layer { layerWidth :: Double -- ^ Array of GIDs. tilelayer only. , layerObjects :: Maybe (Vector Object) -- ^ Array of Objects. objectgroup only. - , layerProperties :: [Property] + , layerProperties :: Maybe [Property] -- ^ string key-value pairs. , layerOpacity :: Float -- ^ Value between 0 and 1 - , layerDraworder :: String + , layerDraworder :: Maybe String -- ^ “topdown” (default) or “index”. objectgroup only. + , layerId :: Int } 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" - <*> (o .:? "properties" <&> fromMaybe []) - <*> o .: "opacity" - <*> (o .: "draworder" <|> pure "topdown") - parseJSON invalid = typeMismatch "Layer" invalid - + parseJSON = genericParseJSON (aesonOptions 5) instance ToJSON Layer where - toJSON Layer{..} = omitNulls $ - 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 - ] + toJSON = genericToJSON (aesonOptions 5) data Terrain = Terrain { terrainName :: String @@ -264,35 +206,28 @@ data Frame = Frame { frameDuration :: Int instance FromJSON Frame where parseJSON (A.Object o) = Frame <$> o .: "duration" - <*> o .: "tileId" + <*> o .: "tileid" parseJSON invalid = typeMismatch "Frame" invalid instance ToJSON Frame where toJSON Frame{..} = object [ "duration" .= frameDuration - , "tileId" .= frameTileId + , "tileid" .= frameTileId ] -data Tile = Tile { tileId :: LocalId - , tileProperties :: Map Text Text +data Tile = Tile { tileId :: Int + , tileProperties :: Maybe (Vector Value) , 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 + parseJSON = genericParseJSON (aesonOptions 4) instance ToJSON Tile where - toJSON Tile{..} = object [ "properties" .= tileProperties - , "image" .= tileImage - , "objectGroup" .= tileObjectGroup - , "animation" .= tileAnimation - ] + toJSON = genericToJSON (aesonOptions 4) + data Tileset = Tileset { tilesetFirstgid :: GlobalId @@ -309,136 +244,88 @@ data Tileset = Tileset { tilesetFirstgid :: GlobalId -- ^ Width of source image in pixels , tilesetImageheight :: Int -- ^ Height of source image in pixels - , tilesetProperties :: [Property] + , tilesetProperties :: Maybe [Property] -- ^ String key-value pairs - , tilesetPropertytypes :: Map Text Text + , 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 :: Map GlobalId (Map Text Text) + , tilesetTileproperties :: Maybe (Map GlobalId (Map Text Text)) -- ^ Per-tile properties, indexed by gid as string - , tilesetTerrains :: Vector Terrain + , 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 :: Map LocalId Tile + , tilesetTiles :: Maybe (Vector Tile) -- ^ Tiles (optional) + , tilesetTransparentcolor :: Maybe String } 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 + parseJSON = genericParseJSON (aesonOptions 7) 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 - ] + toJSON = genericToJSON (aesonOptions 7) -- | The full monty. -data Tiledmap = Tiledmap { tiledmapVersion :: Float +data Tiledmap = Tiledmap { tiledmapVersion :: Float -- ^ The JSON format version - , tiledmapTiledversion :: String + , tiledmapTiledversion :: String -- ^ The Tiled version used to save the file - , tiledmapWidth :: Int + , tiledmapWidth :: Int -- ^ Number of tile columns - , tiledmapHeight :: Int + , tiledmapHeight :: Int -- ^ Number of tile rows - , tiledmapTilewidth :: Double + , tiledmapTilewidth :: Double -- ^ Map grid width. - , tiledmapTileheight :: Double + , tiledmapTileheight :: Double -- ^ Map grid height. - , tiledmapOrientation :: String + , tiledmapOrientation :: String -- ^ Orthogonal, isometric, or staggered - , tiledmapLayers :: Vector Layer + , tiledmapLayers :: Vector Layer -- ^ Array of Layers - , tiledmapTilesets :: Vector Tileset + , tiledmapTilesets :: Vector Tileset -- ^ Array of Tilesets - , tiledmapBackgroundcolor :: Maybe String + , tiledmapBackgroundcolor :: Maybe String -- ^ Hex-formatted color (#RRGGBB or #AARRGGBB) (optional) - , tiledmapRenderorder :: String + , tiledmapRenderorder :: String -- ^ Rendering direction (orthogonal maps only) - , tiledmapProperties :: [Property] + , tiledmapProperties :: Maybe [Property] -- ^ String key-value pairs - , tiledmapNextobjectid :: Int + , tiledmapNextobjectid :: Int -- ^ Auto-increments for each placed object + , tiledmapCompressionLevel :: Maybe Int + , tiledmapInfinite :: Bool + , tiledmapNextlayerid :: Maybe Int + , tiledmapHexsidelength :: Maybe Int + , tiledmapStaggerindex :: Maybe String + , tiledmapType :: String } 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" <&> fromMaybe []) - <*> o .: "nextobjectid" - parseJSON invalid = typeMismatch "Tiledmap" invalid - + parseJSON = genericParseJSON (aesonOptions 8) 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 - ] + toJSON = genericToJSON (aesonOptions 8) + + +class HasProperties a where + getProperties :: a -> [Property] + +instance HasProperties Layer where + getProperties = fromMaybe [] . layerProperties + +instance HasProperties Tileset where + getProperties = fromMaybe [] . tilesetProperties + + data LoadResult = Loaded Tiledmap | IOErr String | DecodeErr String -- cgit v1.2.3