use template haskell aeson, not generics

this has been bothering me for MONTHS, and it compiles faster now. also fixed some warnings

3 files changed, 31 insertions, 55 deletions

diff --git a/tiled/Data/Tiled.hs b/tiled/Data/Tiled.hs
index 3e6c737..4372a97 100644
--- a/tiled/Data/Tiled.hs
+++ b/tiled/Data/Tiled.hs
@@ -1,4 +1,3 @@
-{-# LANGUAGE AllowAmbiguousTypes        #-}
 {-# LANGUAGE BangPatterns               #-}
 {-# LANGUAGE DeriveAnyClass             #-}
 {-# LANGUAGE DeriveGeneric              #-}
@@ -9,6 +8,9 @@
 {-# LANGUAGE OverloadedStrings          #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TemplateHaskell            #-}
+
+
 
 -- | 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/.
@@ -23,27 +25,15 @@ import           Universum
 import           Data.Aeson       hiding (Object)
 import qualified Data.Aeson       as A
 import           Data.Aeson.Types (typeMismatch)
-import           Data.Char        (toLower)
+import           Data.Aeson.TH    (deriveJSON)
 import           Control.Exception (IOException)
+import           Data.Tiled.TH
 
 
--- | 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)
@@ -109,11 +99,6 @@ 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.
@@ -177,15 +162,6 @@ data Object = ObjectRectangle
   } 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
@@ -224,11 +200,6 @@ data Layer = Layer { layerWidth            :: Maybe Double
                    , 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
@@ -275,13 +246,6 @@ data Tile = Tile { tileId          :: Int
                  , 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
@@ -332,13 +296,6 @@ data Tileset = Tileset { tilesetFirstgid         :: GlobalId
 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
@@ -376,10 +333,14 @@ data Tiledmap = Tiledmap { tiledmapVersion          :: Value
                          , tiledmapEditorsettings   :: Maybe Value
                          } deriving (Eq, Generic, Show, NFData)
 
-instance FromJSON Tiledmap where
-  parseJSON = genericParseJSON (aesonOptions 8)
-instance ToJSON Tiledmap where
-  toJSON = genericToJSON (aesonOptions 8)
+
+$(deriveJSON (aesonOptions 5) ''Point)
+$(deriveJSON (aesonOptions 6) ''Object)
+$(deriveJSON (aesonOptions 5) ''Layer)
+$(deriveJSON (aesonOptions 4) ''Tile)
+$(deriveJSON (aesonOptions 7) ''Tileset)
+$(deriveJSON (aesonOptions 8) ''Tiledmap)
+
 
 -- | Load a Tiled map from the given 'FilePath'.
 loadTiledmap :: FilePath -> IO (Either String Tiledmap)
diff --git a/tiled/Data/Tiled/Abstract.hs b/tiled/Data/Tiled/Abstract.hs
index 89c40b4..29e9022 100644
--- a/tiled/Data/Tiled/Abstract.hs
+++ b/tiled/Data/Tiled/Abstract.hs
@@ -4,9 +4,9 @@ module Data.Tiled.Abstract where
 
 import           Universum
 
-import           Data.Tiled  (GlobalId, Layer (..), Object (..), Property (..),
+import           Data.Tiled  (GlobalId (..), Layer (..), Object (..), Property (..),
                               PropertyValue (..), Tile (..), Tiledmap (..),
-                              Tileset (..), mkTiledId)
+                              Tileset (..))
 import qualified Data.Vector as V
 
 class HasProperties a where
@@ -81,4 +81,4 @@ instance IsProperty Text where
 layerIsEmpty :: HasData a => a -> Bool
 layerIsEmpty layer = case getData layer of
   Nothing -> True
-  Just d  -> all ((==) $ mkTiledId 0) d
+  Just d  -> all ((==) $ GlobalId 0) d
diff --git a/tiled/Data/Tiled/TH.hs b/tiled/Data/Tiled/TH.hs
new file mode 100644
index 0000000..e0ad0e8
--- /dev/null
+++ b/tiled/Data/Tiled/TH.hs
@@ -0,0 +1,15 @@
+module Data.Tiled.TH where
+
+import Universum
+
+import qualified Data.Aeson.TH    as TH
+import           Data.Char        (toLower)
+
+aesonOptions :: Int -> TH.Options
+aesonOptions l = TH.defaultOptions
+  { TH.omitNothingFields = True
+  , TH.rejectUnknownFields = True
+  -- can't be bothered to do a nicer prefix strip
+  , TH.fieldLabelModifier = drop l . map toLower
+  , TH.sumEncoding = TH.UntaggedValue
+  }