@@ -52,10 +52,12 @@ instance 'ToJSON' a => 'ToJSON' (D a) where
5252 'object' [T.pack \"Unary\" .= 'toJSON' arg1]
5353 Product arg1 arg2 arg3 ->
5454 'object' [ T.pack \"Product\"
55− .= 'toJSON' [ 'toJSON' arg1
56− , 'toJSON' arg2
57− , 'toJSON' arg3
58− ]
55+ .= ('Array' $ 'V.create' $ do
56+ mv <- 'VM.unsafeNew' 3
57+ 'VM.unsafeWrite' mv 0 ('toJSON' arg1)
58+ 'VM.unsafeWrite' mv 1 ('toJSON' arg2)
59+ 'VM.unsafeWrite' mv 2 ('toJSON' arg3)
60+ return mv)
5961 ]
6062 Record arg1 arg2 arg3 ->
6163 'object' [ T.pack \"Record\"
@@ -164,7 +166,7 @@ import Data.List ( (++), foldl, foldl', intercalate
164166 , length, map, zip, genericLength
165167 )
166168import Data.Maybe ( Maybe(Nothing, Just) )
167−import Prelude ( String, (-), Integer, error )
169+import Prelude ( String, (-), Integer, fromIntegral, error )
168170import Text.Printf ( printf )
169171import Text.Show ( show )
170172#if __GLASGOW_HASKELL__ < 700
@@ -178,8 +180,8 @@ import Language.Haskell.TH
178180-- from text:
179181import qualified Data.Text as T ( Text, pack, unpack )
180182-- from vector:
181−import qualified Data.Vector as V ( unsafeIndex, null, length )
182−
183+import qualified Data.Vector as V ( unsafeIndex, null, length, create )
184+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
183185
184186
185187--------------------------------------------------------------------------------
@@ -231,7 +233,11 @@ The above (ToJSON a) constraint is not necessary and perhaps undesirable.
231233-- instance 'ToJSON' Foo where
232234-- 'toJSON' =
233235-- \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
235241-- @
236242deriveToJSON :: (String -> String)
237243 -- ^ Function to change field names.
@@ -327,12 +333,28 @@ encodeArgs withExp _ (NormalC conName []) =
327333 []
328334-- Polyadic constructors with special case for unary constructors.
329335encodeArgs withExp _ (NormalC conName ts) = do
330− args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]]
331− let js = case [[e|toJSON|] `appE` varE arg | arg <- args] of
332− -- Single argument is directly converted.
333− [e] -> e
334− -- Multiple arguments are converted to a JSON array.
335− es -> [e|toJSON|] `appE` listE es
336+ let len = length ts
337+ args <- mapM newName ["arg" ++ show n | n <- [1..len]]
338+ js <- case [[e|toJSON|] `appE` varE arg | arg <- args] of
339+ -- Single argument is directly converted.
340+ [e] -> return e
341+ -- Multiple arguments are converted to a JSON array.
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]))
336358 match (conP conName $ map varP args)
337359 (normalB $ withExp js)
338360 []