Skip to content

Commit c3d5567

Browse files
isovectorschell
isovector
authored and
schell
committed
parse objects correctly (#1)
1 parent afdafeb commit c3d5567

File tree

6 files changed

+156
-75
lines changed

6 files changed

+156
-75
lines changed

‎aeson-tiled.cabal‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ test-suite aeson-tiled-test
4242
, aeson >= 1.1
4343
, aeson-tiled
4444
, hspec
45+
, bytestring
4546
ghc-options: -threaded -rtsopts -with-rtsopts=-N
4647
default-language: Haskell2010
4748

‎maps/objects/obj1.json‎

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
{
2+
"height":0,
3+
"id":4,
4+
"name":"",
5+
"polyline":[
6+
{
7+
"x":0,
8+
"y":0
9+
},
10+
{
11+
"x":0,
12+
"y":32
13+
}],
14+
"rotation":0,
15+
"type":"",
16+
"visible":true,
17+
"width":0,
18+
"x":16,
19+
"y":16
20+
}

‎src/Data/Aeson/Tiled.hs‎

Lines changed: 86 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -24,8 +24,10 @@ import Data.Aeson.Types (Parser, typeMismatch)
2424
import qualified Data.ByteString.Lazy.Char8 as C8
2525
import Data.Map (Map)
2626
import qualified Data.Map as M
27+
import Data.Maybe (fromMaybe)
2728
import Data.Text (Text)
2829
import Data.Vector (Vector)
30+
import GHC.Exts (fromList, toList)
2931
import GHC.Generics (Generic)
3032

3133

@@ -39,11 +41,42 @@ newtype LocalId = LocalId { unLocalId :: Int }
3941
deriving (Ord, Eq, Enum, Num, Generic, Show, FromJSON, ToJSON, FromJSONKey, ToJSONKey)
4042

4143

44+
data XYPair a = XYPair a a
45+
46+
instance FromJSON a => FromJSON (XYPair a) where
47+
parseJSON (A.Object o) =
48+
XYPair <$> o .: "x"
49+
<*> o .: "y"
50+
parseJSON invalid = typeMismatch "Object" invalid
51+
52+
instance ToJSON a => ToJSON (XYPair a) where
53+
toJSON (XYPair x y) =
54+
object [ "x" .= x
55+
, "y" .= y
56+
]
57+
58+
fromXYPair :: XYPair a -> (a, a)
59+
fromXYPair (XYPair x y) = (x, y)
60+
61+
toXYPair :: (a, a) -> XYPair a
62+
toXYPair (x, y) = XYPair x y
63+
64+
omitNulls :: Value -> Value
65+
omitNulls (A.Object hs) = A.Object
66+
. fromList
67+
. filter ((/= Null) . snd)
68+
$ toList hs
69+
omitNulls x = x
70+
71+
parseDefault :: FromJSON a => A.Object -> Text -> a -> Parser a
72+
parseDefault o s d = fromMaybe d <$> o .:? s
73+
74+
4275
data Object = Object { objectId :: Int
4376
-- ^ Incremental id - unique across all objects
44-
, objectWidth :: Int
77+
, objectWidth :: Double
4578
-- ^ Width in pixels. Ignored if using a gid.
46-
, objectHeight :: Int
79+
, objectHeight :: Double
4780
-- ^ Height in pixels. Ignored if using a gid.
4881
, objectName :: String
4982
-- ^ String assigned to name field in editor
@@ -53,19 +86,19 @@ data Object = Object { objectId :: Int
5386
-- ^ String key-value pairs
5487
, objectVisible :: Bool
5588
-- ^ Whether object is shown in editor.
56-
, objectX :: Int
89+
, objectX :: Double
5790
-- ^ x coordinate in pixels
58-
, objectY :: Int
91+
, objectY :: Double
5992
-- ^ y coordinate in pixels
6093
, objectRotation :: Float
6194
-- ^ Angle in degrees clockwise
62-
, objectGid :: GlobalId
95+
, objectGid :: Maybe GlobalId
6396
-- ^ GID, only if object comes from a Tilemap
6497
, objectEllipse :: Bool
6598
-- ^ Used to mark an object as an ellipse
66-
, objectPolygon :: Vector (Int, Int)
99+
, objectPolygon :: Maybe (Vector (Double, Double))
67100
-- ^ A list of x,y coordinates in pixels
68-
, objectPolyline :: Vector (Int, Int)
101+
, objectPolyline :: Maybe (Vector (Double, Double))
69102
-- ^ A list of x,y coordinates in pixels
70103
, objectText :: Map Text Text
71104
-- ^ String key-value pairs
@@ -77,50 +110,51 @@ instance FromJSON Object where
77110
<*> o .: "height"
78111
<*> o .: "name"
79112
<*> o .: "type"
80-
<*> o .: "properties"
113+
<*> parseDefault o "properties" M.empty
81114
<*> o .: "visible"
82115
<*> o .: "x"
83116
<*> o .: "y"
84117
<*> o .: "rotation"
85-
<*> o .: "gid"
86-
<*> o .: "ellipse"
87-
<*> o .: "polygon"
88-
<*> o .: "polyline"
89-
<*> o .: "text"
118+
<*> o .:? "gid"
119+
<*> parseDefault o "ellipse" False
120+
<*> (fmap . fmap . fmap) fromXYPair (o .:? "polygon")
121+
<*> (fmap . fmap . fmap) fromXYPair (o .:? "polyline")
122+
<*> parseDefault o "text" M.empty
90123
parseJSON invalid = typeMismatch "Object" invalid
91124

92125
instance ToJSON Object where
93-
toJSON Object{..} = object [ "id" .= objectId
94-
, "width" .= objectWidth
95-
, "height" .= objectHeight
96-
, "name" .= objectName
97-
, "type" .= objectType
98-
, "properties" .= objectProperties
99-
, "visible" .= objectVisible
100-
, "x" .= objectX
101-
, "y" .= objectY
102-
, "rotation" .= objectRotation
103-
, "gid" .= objectGid
104-
, "ellipse" .= objectEllipse
105-
, "polygon" .= objectPolygon
106-
, "polyline" .= objectPolyline
107-
, "text" .= objectText
108-
]
109-
110-
111-
data Layer = Layer { layerWidth :: Int
126+
toJSON Object{..} = omitNulls $
127+
object [ "id" .= objectId
128+
, "width" .= objectWidth
129+
, "height" .= objectHeight
130+
, "name" .= objectName
131+
, "type" .= objectType
132+
, "properties" .= objectProperties
133+
, "visible" .= objectVisible
134+
, "x" .= objectX
135+
, "y" .= objectY
136+
, "rotation" .= objectRotation
137+
, "gid" .= objectGid
138+
, "ellipse" .= objectEllipse
139+
, "polygon" .= (fmap . fmap) toXYPair objectPolygon
140+
, "polyline" .= (fmap . fmap) toXYPair objectPolyline
141+
, "text" .= objectText
142+
]
143+
144+
145+
data Layer = Layer { layerWidth :: Double
112146
-- ^ Column count. Same as map width for fixed-size maps.
113-
, layerHeight :: Int
147+
, layerHeight :: Double
114148
-- ^ Row count. Same as map height for fixed-size maps.
115149
, layerName :: String
116150
-- ^ Name assigned to this layer
117151
, layerType :: String
118152
-- ^ “tilelayer”, “objectgroup”, or “imagelayer”
119153
, layerVisible :: Bool
120154
-- ^ Whether layer is shown or hidden in editor
121-
, layerX :: Int
155+
, layerX :: Double
122156
-- ^ Horizontal layer offset in tiles. Always 0.
123-
, layerY :: Int
157+
, layerY :: Double
124158
-- ^ Vertical layer offset in tiles. Always 0.
125159
, layerData :: Maybe (Vector GlobalId)
126160
-- ^ Array of GIDs. tilelayer only.
@@ -143,26 +177,27 @@ instance FromJSON Layer where
143177
<*> o .: "x"
144178
<*> o .: "y"
145179
<*> (o .: "data" <|> pure Nothing)
146-
<*> (o .: "objects" <|> pure Nothing)
180+
<*> o .:? "objects"
147181
<*> (o .: "properties" <|> pure mempty)
148182
<*> o .: "opacity"
149183
<*> (o .: "draworder" <|> pure "topdown")
150184
parseJSON invalid = typeMismatch "Layer" invalid
151185

152186
instance ToJSON Layer where
153-
toJSON Layer{..} = object [ "width" .= layerWidth
154-
, "height" .= layerHeight
155-
, "name" .= layerName
156-
, "type" .= layerType
157-
, "visible" .= layerVisible
158-
, "x" .= layerX
159-
, "y" .= layerY
160-
, "data" .= layerData
161-
, "objects" .= layerObjects
162-
, "properties" .= layerProperties
163-
, "opacity" .= layerOpacity
164-
, "draworder" .= layerDraworder
165-
]
187+
toJSON Layer{..} = omitNulls $
188+
object [ "width" .= layerWidth
189+
, "height" .= layerHeight
190+
, "name" .= layerName
191+
, "type" .= layerType
192+
, "visible" .= layerVisible
193+
, "x" .= layerX
194+
, "y" .= layerY
195+
, "data" .= layerData
196+
, "objects" .= layerObjects
197+
, "properties" .= layerProperties
198+
, "opacity" .= layerOpacity
199+
, "draworder" .= layerDraworder
200+
]
166201

167202

168203
data Terrain = Terrain { terrainName :: String
@@ -313,9 +348,9 @@ data Tiledmap = Tiledmap { tiledmapVersion :: Float
313348
-- ^ Number of tile columns
314349
, tiledmapHeight :: Int
315350
-- ^ Number of tile rows
316-
, tiledmapTilewidth :: Int
351+
, tiledmapTilewidth :: Double
317352
-- ^ Map grid width.
318-
, tiledmapTileheight :: Int
353+
, tiledmapTileheight :: Double
319354
-- ^ Map grid height.
320355
, tiledmapOrientation :: String
321356
-- ^ Orthogonal, isometric, or staggered

‎test/ParseObjectSpec.hs‎

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE TypeApplications #-}
3+
4+
module ParseObjectSpec where
5+
6+
import Data.Aeson (encode, eitherDecode)
7+
import Test.Hspec
8+
import Data.Either (isRight)
9+
import Control.Monad (forM_)
10+
import qualified Data.ByteString.Lazy.Char8 as C8
11+
12+
import Data.Aeson.Tiled
13+
14+
file :: FilePath
15+
file = "maps/objects/obj1.json"
16+
17+
spec :: Spec
18+
spec = describe "Obj1" $ do
19+
it "should parse just fine" $ do
20+
eobj <- fmap (eitherDecode @Object) $ C8.readFile file
21+
eobj `shouldSatisfy` isRight
22+

‎test/RoundTripSpec.hs‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
{-# LANGUAGE LambdaCase #-}
2+
3+
module RoundTripSpec where
4+
5+
import Data.Aeson (encode, eitherDecode)
6+
import Test.Hspec
7+
import Control.Monad (forM_)
8+
9+
import Data.Aeson.Tiled
10+
11+
files :: [FilePath]
12+
files = [ "maps/example.json"
13+
, "maps/test1.json"
14+
, "maps/test2.json"
15+
, "maps/test3.json"
16+
, "maps/test4.json"
17+
]
18+
19+
spec :: Spec
20+
spec = describe "Round tripping" . forM_ files $ \file ->
21+
it (file ++ " should roundtrip and end up with the same Tiledmap") $
22+
loadTiledmap file >>= \case
23+
Right tm -> do
24+
let bs = encode tm
25+
eitherDecode bs `shouldBe` Right tm
26+
Left x -> fail x

‎test/Spec.hs‎

Lines changed: 1 addition & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -1,24 +1 @@
1-
{-# LANGUAGE LambdaCase #-}
2-
import Data.Aeson (encode, eitherDecode)
3-
import Test.Hspec
4-
import Control.Monad (forM_)
5-
6-
import Data.Aeson.Tiled
7-
8-
files :: [FilePath]
9-
files = [ "maps/example.json"
10-
, "maps/test1.json"
11-
, "maps/test2.json"
12-
, "maps/test3.json"
13-
, "maps/test4.json"
14-
]
15-
16-
main :: IO ()
17-
main = hspec $ forM_ files $ \file ->
18-
describe ("With " ++ show file) $
19-
it "loading and encoding and decoding should end up with the same Tiledmap" $
20-
loadTiledmap file >>= \case
21-
Right tm -> do
22-
let bs = encode tm
23-
eitherDecode bs `shouldBe` Right tm
24-
_ -> fail $ "Could not decode Tiledmap from " ++ show file
1+
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

0 commit comments

Comments
 (0)