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 …

3 files changed, 79 insertions, 198 deletions

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