ab30765 · typeable/aeson

git.iko.soy/typeable/aeson

on master help sign in

Improved performance of the template-haskell derived toJSON for products by 70%

ab30765Bas van Dijk15 years ago

Data/Aeson/TH.hs+36−14

compare with master

unifiedsplit

@@ -52,10 +52,12 @@ instance 'ToJSON' a => 'ToJSON' (D a) where

52 'object' [T.pack \"Unary\" .= 'toJSON' arg1]

53 Product arg1 arg2 arg3 ->

54 'object' [ T.pack \"Product\"

55+ .= ('Array' $ 'V.create' $ do

56+ mv <- 'VM.unsafeNew' 3

55− .= 'toJSON' [ 'toJSON' arg1

57+ 'VM.unsafeWrite' mv 0 ('toJSON' arg1)

56− , 'toJSON' arg2

58+ 'VM.unsafeWrite' mv 1 ('toJSON' arg2)

57− , 'toJSON' arg3

59+ 'VM.unsafeWrite' mv 2 ('toJSON' arg3)

58− ]

60+ return mv)

59 ]

61 ]

60 Record arg1 arg2 arg3 ->

62 Record arg1 arg2 arg3 ->

61 'object' [ T.pack \"Record\"

63 'object' [ T.pack \"Record\"

@@ -164,7 +166,7 @@ import Data.List ( (++), foldl, foldl', intercalate

164 , length, map, zip, genericLength

166 , length, map, zip, genericLength

165 )

167 )

166import Data.Maybe ( Maybe(Nothing, Just) )

168import Data.Maybe ( Maybe(Nothing, Just) )

167−import Prelude ( String, (-), Integer, error )

169+import Prelude ( String, (-), Integer, fromIntegral, error )

168import Text.Printf ( printf )

170import Text.Printf ( printf )

169import Text.Show ( show )

171import Text.Show ( show )

170#if __GLASGOW_HASKELL__ < 700

172#if __GLASGOW_HASKELL__ < 700

@@ -178,8 +180,8 @@ import Language.Haskell.TH

178-- from text:

180-- from text:

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

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

180-- from vector:

182-- from vector:

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

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

182−

184+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )

183

185

184

186

185--------------------------------------------------------------------------------

187--------------------------------------------------------------------------------

@@ -231,7 +233,11 @@ The above (ToJSON a) constraint is not necessary and perhaps undesirable.

231-- instance 'ToJSON' Foo where

233-- instance 'ToJSON' Foo where

232-- 'toJSON' =

234-- 'toJSON' =

233-- \value -> case value of

235-- \value -> case value of

234−-- Foo arg1 arg2 -> 'toJSON' ['toJSON' arg1, 'toJSON' arg2]

236+-- Foo arg1 arg2 -> 'Array' $ 'V.create' $ do

237+-- mv <- 'VM.unsafeNew' 2

238+-- 'VM.unsafeWrite' mv 0 ('toJSON' arg1)

239+-- 'VM.unsafeWrite' mv 1 ('toJSON' arg2)

240+-- return mv

235-- @

241-- @

236deriveToJSON :: (String -> String)

242deriveToJSON :: (String -> String)

237 -- ^ Function to change field names.

243 -- ^ Function to change field names.

@@ -327,12 +333,28 @@ encodeArgs withExp _ (NormalC conName []) =

327 []

333 []

328-- Polyadic constructors with special case for unary constructors.

334-- Polyadic constructors with special case for unary constructors.

329encodeArgs withExp _ (NormalC conName ts) = do

335encodeArgs withExp _ (NormalC conName ts) = do

336+ let len = length ts

330− args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]

337+ args <- mapM newName ["arg" ++ show n | n <- [1..len]]

331− let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of

338+ js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of

332− -- Single argument is directly converted.

339+ -- Single argument is directly converted.

333− [e] -> e

340+ [e] -> return e

334− -- Multiple arguments are converted to a JSON array.

341+ -- Multiple arguments are converted to a JSON array.

335− es -> [e|toJSON|] `appE` listE es

342+ es -> do

343+ mv <- newName "mv"

344+ let newMV = bindS (varP mv)

345+ ([e|VM.unsafeNew|] `appE`

346+ litE (integerL $ fromIntegral len))

347+ stmts = [ noBindS $

348+ [e|VM.unsafeWrite|] `appE`

349+ (varE mv) `appE`

350+ litE (integerL ix) `appE`

351+ e

352+ | (ix, e) <- zip [(0::Integer)..] es

353+ ]

354+ ret = noBindS $ [e|return|] `appE` varE mv

355+ return $ [e|Array|] `appE`

356+ ([e|V.create|] `appE`

357+ doE (newMV:stmts++[ret]))

336 match (conP conName $ map varP args)

358 match (conP conName $ map varP args)

337 (normalB $ withExp js)

359 (normalB $ withExp js)

338 []

360 []