17de902 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Merge pull request #36 from basvandijk/optimizations

17de902Bryan O'Sullivan15 years ago

Data/Aeson/TH.hs+9−9

compare with master

unifiedsplit

@@ -89,9 +89,9 @@ instance 'FromJSON' a => 'FromJSON' (D a) where

89 case conVal of

90 'Array' arr ->

91 if V.length arr == 3

92− then Product \<$\> 'parseJSON' (arr V.! 0)

92+ then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)

93− \<*\> 'parseJSON' (arr V.! 1)

93+ \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)

94− \<*\> 'parseJSON' (arr V.! 2)

94+ \<*\> 'parseJSON' (arr `V.unsafeIndex` 2)

95 else fail \"\<error message\>\"

96 _ -> fail \"\<error message\>\"

97 | conKey == T.pack \"Record\" ->

@@ -168,7 +168,7 @@ import Prelude ( String, (-), Integer, error )

168import Text.Printf ( printf )

169import Text.Show ( show )

170#if __GLASGOW_HASKELL__ < 700

171−import Control.Monad ( (>>=) )

171+import Control.Monad ( (>>=), fail )

172import Prelude ( fromInteger )

173#endif

174-- from containers:

@@ -178,7 +178,7 @@ import Language.Haskell.TH

178-- from text:

179import qualified Data.Text as T ( Text, pack, unpack )

180-- from vector:

181−import qualified Data.Vector as V ( (!), null, length )

181+import qualified Data.Vector as V ( unsafeIndex, null, length )

182

183

184

@@ -385,8 +385,8 @@ encodeArgs withExp withField (ForallC _ _ con) =

385-- \value -> case value of

386-- 'Array' arr ->

387-- if (V.length arr == 2)

388−-- then Foo \<$\> 'parseJSON' (arr V.! 0)

388+-- then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)

389−-- \<*\> 'parseJSON' (arr V.! 1)

389+-- \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)

390-- else fail \"\<error message\>\"

391-- other -> fail \"\<error message\>\"

392-- @

@@ -600,11 +600,11 @@ parseProduct :: Name -- ^ Name of the type to which the constructor belongs.

600 -> [Q Match]

601parseProduct tName conName numArgs =

602 [ do arr <- newName "arr"

603− -- List of: "parseJSON (arr V.! <IX>)"

603+ -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"

604 let x:xs = [ [|parseJSON|]

605 `appE`

606 infixApp (varE arr)

607− [|(V.!)|]

607+ [|V.unsafeIndex|]

608 (litE $ integerL ix)

609 | ix <- [0 .. numArgs - 1]

610 ]

Data/Aeson/Types/Class.hs+12−5

@@ -1,6 +1,13 @@

1+{-# LANGUAGE CPP

1−{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,

2+ , DeriveDataTypeable

3+ , FlexibleContexts

4+ , FlexibleInstances

2− GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,

5+ , GeneralizedNewtypeDeriving

6+ , OverlappingInstances

7+ , OverloadedStrings

3− OverloadedStrings, UndecidableInstances, ViewPatterns #-}

8+ , UndecidableInstances

9+ , ViewPatterns

10+ #-}

5#ifdef GENERICS

12#ifdef GENERICS

6{-# LANGUAGE DefaultSignatures #-}

13{-# LANGUAGE DefaultSignatures #-}

@@ -104,7 +111,7 @@ class GFromJSON f where

104--

111--

105-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any

112-- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any

106-- type which is an instance of 'Data'.

113-- type which is an instance of 'Data'.

107−--

114+--

108-- * If your compiler has support for the @DeriveGeneric@ and

115-- * If your compiler has support for the @DeriveGeneric@ and

109-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic

116-- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic

110-- implementation.

117-- implementation.

@@ -143,7 +150,7 @@ class ToJSON a where

143-- @{-\# LANGUAGE OverloadedStrings #-}

150-- @{-\# LANGUAGE OverloadedStrings #-}

144--

151--

145-- data Coord { x :: Double, y :: Double }

152-- data Coord { x :: Double, y :: Double }

146−--

153+--

147-- instance FromJSON Coord where

154-- instance FromJSON Coord where

148-- parseJSON ('Object' v) = Coord '<$>'

155-- parseJSON ('Object' v) = Coord '<$>'

149-- v '.:' \"x\" '<*>'

156-- v '.:' \"x\" '<*>'

Data/Aeson/Types/Generic.hs+65−28

@@ -1,7 +1,15 @@

1−{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleContexts,

1+{-# LANGUAGE DefaultSignatures

2+ , EmptyDataDecls

3+ , FlexibleInstances

2− FlexibleInstances, FunctionalDependencies, IncoherentInstances,

4+ , FunctionalDependencies

5+ , KindSignatures

3− KindSignatures, OverlappingInstances, ScopedTypeVariables, TypeOperators,

6+ , OverlappingInstances

7+ , ScopedTypeVariables

8+ , TypeOperators

4− UndecidableInstances, ViewPatterns #-}

9+ , UndecidableInstances

10+ , ViewPatterns

11+ #-}

12+

5{-# OPTIONS_GHC -fno-warn-orphans #-}

13{-# OPTIONS_GHC -fno-warn-orphans #-}

7-- |

15-- |

@@ -18,10 +26,10 @@ module Data.Aeson.Types.Generic ( ) where

19import Control.Applicative

27import Control.Applicative

20import Control.Monad.State.Strict

28import Control.Monad.State.Strict

29+import Data.Bits (shiftR)

21import Data.Aeson.Types.Class

30import Data.Aeson.Types.Class

22import Data.Aeson.Types.Internal

31import Data.Aeson.Types.Internal

23import Data.Text (pack, unpack)

32import Data.Text (pack, unpack)

24−import Data.Vector ((!?))

25import GHC.Generics

33import GHC.Generics

26import qualified Data.Map as M

34import qualified Data.Map as M

27import qualified Data.Text as T

35import qualified Data.Text as T

@@ -60,6 +68,8 @@ instance (GObject a, GObject b) => GToJSON (a :+: b) where

60class ConsToJSON f where consToJSON :: f a -> Value

68class ConsToJSON f where consToJSON :: f a -> Value

61class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)

69class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)

71+newtype Tagged s b = Tagged {unTagged :: b}

72+

63instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where

73instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where

64 consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))

74 consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))

65 {-# INLINE consToJSON #-}

75 {-# INLINE consToJSON #-}

@@ -109,7 +119,7 @@ instance (GObject a, GObject b) => GObject (a :+: b) where

109 {-# INLINE gObject #-}

119 {-# INLINE gObject #-}

110

120

111instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where

121instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where

112− gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)

122+ gObject = M.singleton (pack $ conName (undefined :: t c a p)) . gToJSON

113 {-# INLINE gObject #-}

123 {-# INLINE gObject #-}

114

124

115--------------------------------------------------------------------------------

125--------------------------------------------------------------------------------

@@ -133,16 +143,33 @@ instance (ConsFromJSON a) => GFromJSON (C1 c a) where

133 gParseJSON = fmap M1 . consParseJSON

143 gParseJSON = fmap M1 . consParseJSON

134 {-# INLINE gParseJSON #-}

144 {-# INLINE gParseJSON #-}

135

145

136−instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where

146+instance ( GFromProduct a, GFromProduct b

147+ , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where

137− gParseJSON (Array arr) = gParseProduct arr

148+ gParseJSON (Array arr)

149+ | lenArray == lenProduct = gParseProduct arr 0 lenProduct

150+ | otherwise =

151+ fail $ "When expecting a product of " ++ show lenProduct ++

152+ " values, encountered an Array of " ++ show lenArray ++

153+ " elements instead"

154+ where

155+ lenArray = V.length arr

156+ lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)

157+

138 gParseJSON v = typeMismatch "product (:*:)" v

158 gParseJSON v = typeMismatch "product (:*:)" v

139 {-# INLINE gParseJSON #-}

159 {-# INLINE gParseJSON #-}

140

160

141instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where

161instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where

142− gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal

162+ gParseJSON (Object (M.toList -> [keyVal@(key, _)])) =

163+ case gParseSum keyVal of

164+ Nothing -> notFound $ unpack key

165+ Just p -> p

143 gParseJSON v = typeMismatch "sum (:+:)" v

166 gParseJSON v = typeMismatch "sum (:+:)" v

144 {-# INLINE gParseJSON #-}

167 {-# INLINE gParseJSON #-}

145

168

169+notFound :: String -> Parser a

170+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"

171+{-# INLINE notFound #-}

172+

146--------------------------------------------------------------------------------

173--------------------------------------------------------------------------------

147

174

148class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)

175class ConsFromJSON f where consParseJSON :: Value -> Parser (f a)

@@ -173,56 +200,66 @@ instance (GFromRecord a, GFromRecord b) => GFromRecord (a :*: b) where

173 {-# INLINE gParseRecord #-}

200 {-# INLINE gParseRecord #-}

174

201

175instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where

202instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where

176− gParseRecord obj = case M.lookup (T.pack key) obj of

203+ gParseRecord = maybe (notFound key) gParseJSON . M.lookup (T.pack key)

177− Nothing -> notFound key

178− Just v -> gParseJSON v

179 where

204 where

180 key = selName (undefined :: t s a p)

205 key = selName (undefined :: t s a p)

181 {-# INLINE gParseRecord #-}

206 {-# INLINE gParseRecord #-}

182

207

183--------------------------------------------------------------------------------

208--------------------------------------------------------------------------------

184

209

210+class ProductSize f where

211+ productSize :: Tagged2 f Int

212+

213+newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

214+

215+instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where

216+ productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +

217+ unTagged2 (productSize :: Tagged2 b Int)

218+

219+instance ProductSize (S1 s a) where

220+ productSize = Tagged2 1

221+

222+--------------------------------------------------------------------------------

223+

185class GFromProduct f where

224class GFromProduct f where

186− gParseProduct :: Array -> Parser (f a)

225+ gParseProduct :: Array -> Int -> Int -> Parser (f a)

187

226

188instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where

227instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where

189− gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR

228+ gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix lenL

229+ <*> gParseProduct arr ixR lenR

190 where

230 where

191− (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr

231+ lenL = len `shiftR` 1

232+ ixR = ix + lenL

233+ lenR = len - lenL

192 {-# INLINE gParseProduct #-}

234 {-# INLINE gParseProduct #-}

193

235

194−instance (GFromJSON a) => GFromProduct a where

236+instance (GFromJSON a) => GFromProduct (S1 s a) where

195− gParseProduct ((!? 0) -> Just v) = gParseJSON v

237+ gParseProduct arr ix _ = gParseJSON $ V.unsafeIndex arr ix

196− gParseProduct _ = fail "Array to small"

197 {-# INLINE gParseProduct #-}

238 {-# INLINE gParseProduct #-}

198

239

199--------------------------------------------------------------------------------

240--------------------------------------------------------------------------------

200

241

201class GFromSum f where

242class GFromSum f where

202− gParseSum :: Pair -> Parser (f a)

243+ gParseSum :: Pair -> Maybe (Parser (f a))

203

244

204instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where

245instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where

205− gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)

246+ gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|>

247+ (fmap R1 <$> gParseSum keyVal)

206 {-# INLINE gParseSum #-}

248 {-# INLINE gParseSum #-}

207

249

208instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where

250instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where

209 gParseSum (key, value)

251 gParseSum (key, value)

210− | key == pack (conName (undefined :: t c a p)) = gParseJSON value

252+ | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value

211− | otherwise = notFound $ unpack key

253+ | otherwise = Nothing

212 {-# INLINE gParseSum #-}

254 {-# INLINE gParseSum #-}

213

255

214−notFound :: String -> Parser a

215−notFound key = fail $ "The key \"" ++ key ++ "\" was not found"

216−

217--------------------------------------------------------------------------------

256--------------------------------------------------------------------------------

218

257

219−newtype Tagged s b = Tagged {unTagged :: b}

258+class IsRecord (f :: * -> *) b | f -> b

220

259

221data True

260data True

222data False

261data False

223

262

224−class IsRecord (f :: * -> *) b | f -> b

225−

226instance (IsRecord f b) => IsRecord (f :*: g) b

263instance (IsRecord f b) => IsRecord (f :*: g) b

227instance IsRecord (M1 S NoSelector f) False

264instance IsRecord (M1 S NoSelector f) False

228instance (IsRecord f b) => IsRecord (M1 S c f) b

265instance (IsRecord f b) => IsRecord (M1 S c f) b

Data/Aeson/Types/Internal.hs+1−6

@@ -1,9 +1,4 @@

1−{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,

1+{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-}

2− IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,

3− ViewPatterns, FlexibleContexts, UndecidableInstances,

4− ScopedTypeVariables, PatternGuards #-}

5−

6−{-# LANGUAGE CPP #-}

8-- |

3-- |

9-- Module: Data.Aeson.Types.Internal

4-- Module: Data.Aeson.Types.Internal

aeson.cabal+2−4

@@ -120,6 +120,8 @@ library

120 Data.Aeson.Types.Internal

121

122 if impl(ghc >= 7.2.1)

123+ cpp-options: -DGENERICS

124+ build-depends: ghc-prim >= 0.2

123 other-modules:

125 other-modules:

124 Data.Aeson.Types.Generic

126 Data.Aeson.Types.Generic

125

127

@@ -145,10 +147,6 @@ library

145 ghc-options: -Werror

147 ghc-options: -Werror

146 ghc-prof-options: -auto-all

148 ghc-prof-options: -auto-all

147

149

148− if impl(ghc >= 7.2.1)

149− cpp-options: -DGENERICS

150− build-depends: ghc-prim >= 0.2

151−

152 ghc-options: -Wall

150 ghc-options: -Wall

153

151

154test-suite tests

152test-suite tests

benchmarks/AesonCompareAutoInstances.hs+25−25

@@ -25,7 +25,7 @@ data D a = Nullary

25 | Record { testOne :: Double

26 , testTwo :: Bool

27 , testThree :: D a

28− } deriving (Eq, Generic, Data, Typeable)

28+ } deriving (Show, Eq, Generic, Data, Typeable)

30instance NFData a => NFData (D a) where

31 rnf Nullary = ()

@@ -62,20 +62,20 @@ thDFromJSON = parse thDParseJSON

62--------------------------------------------------------------------------------

64data BigRecord = BigRecord

65− { field01 :: !(), field02 :: !(), field03 :: !(), field04 :: !(), field05 :: !()

65+ { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int

66− , field06 :: !(), field07 :: !(), field08 :: !(), field09 :: !(), field10 :: !()

66+ , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int

67− , field11 :: !(), field12 :: !(), field13 :: !(), field14 :: !(), field15 :: !()

67+ , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int

68− , field16 :: !(), field17 :: !(), field18 :: !(), field19 :: !(), field20 :: !()

68+ , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int

69− , field21 :: !(), field22 :: !(), field23 :: !(), field24 :: !(), field25 :: !()

69+ , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int

70− } deriving (Eq, Generic, Data, Typeable)

70+ } deriving (Show, Eq, Generic, Data, Typeable)

72instance NFData BigRecord

74−bigRecord = BigRecord () () () () ()

74+bigRecord = BigRecord 1 2 3 4 5

75− () () () () ()

75+ 6 7 8 9 10

76− () () () () ()

76+ 11 12 13 14 15

77− () () () () ()

77+ 16 17 18 19 20

78− () () () () ()

78+ 21 22 23 24 25

80instance ToJSON BigRecord

81instance FromJSON BigRecord

@@ -92,20 +92,20 @@ thBigRecordFromJSON = parse thBigRecordParseJSON

92--------------------------------------------------------------------------------

94data BigProduct = BigProduct

95− !() !() !() !() !()

95+ !Int !Int !Int !Int !Int

96− !() !() !() !() !()

96+ !Int !Int !Int !Int !Int

97− !() !() !() !() !()

97+ !Int !Int !Int !Int !Int

98− !() !() !() !() !()

98+ !Int !Int !Int !Int !Int

99− !() !() !() !() !()

99+ !Int !Int !Int !Int !Int

100− deriving (Eq, Generic, Data, Typeable)

100+ deriving (Show, Eq, Generic, Data, Typeable)

101

102instance NFData BigProduct

103

104−bigProduct = BigProduct () () () () ()

104+bigProduct = BigProduct 1 2 3 4 5

105− () () () () ()

105+ 6 7 8 9 10

106− () () () () ()

106+ 11 12 13 14 15

107− () () () () ()

107+ 16 17 18 19 20

108− () () () () ()

108+ 21 22 23 24 25

109

110instance ToJSON BigProduct

111instance FromJSON BigProduct

@@ -126,11 +126,11 @@ data BigSum = F01 | F02 | F03 | F04 | F05

126 | F11 | F12 | F13 | F14 | F15

127 | F16 | F17 | F18 | F19 | F20

128 | F21 | F22 | F23 | F24 | F25

129− deriving (Eq, Generic, Data, Typeable)

129+ deriving (Show, Eq, Generic, Data, Typeable)

130

131instance NFData BigSum

132

133−bigSum = F12

133+bigSum = F25

134

135instance ToJSON BigSum

136instance FromJSON BigSum