summaryrefslogtreecommitdiff
path: root/tiled
diff options
context:
space:
mode:
authorstuebinm2022-10-11 13:39:16 +0200
committerstuebinm2022-10-11 13:39:16 +0200
commit4caded904c54d1cd85bf54239517e93650a404f5 (patch)
treece150d3588aa766c12ee6bb3e3ed3aea73615d43 /tiled
parente4b0ae395f3207f4bbaebbf42a3d3a28a516489d (diff)
use template haskell aeson, not generics
this has been bothering me for MONTHS, and it compiles faster now. also fixed some warnings
Diffstat (limited to 'tiled')
-rw-r--r--tiled/Data/Tiled.hs65
-rw-r--r--tiled/Data/Tiled/Abstract.hs6
-rw-r--r--tiled/Data/Tiled/TH.hs15
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
+ }