git.iko.soy/typeable/aeson
on master help sign in
Merge pull request #48 from basvandijk/faster-tuples
eddbbf5Bryan O'Sullivan
Data/Aeson/Types/Class.hs+46−24
compare with master
unifiedsplit
@@ -71,6 +71,7 @@ import qualified Data.Vector.Generic as VG
71import qualified Data.Vector.Primitive as VP
71import qualified Data.Vector.Primitive as VP
72import qualified Data.Vector.Storable as VS
72import qualified Data.Vector.Storable as VS
73import qualified Data.Vector.Unboxed as VU
73import qualified Data.Vector.Unboxed as VU
74+import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite )
74
75
75#ifdef GENERICS
76#ifdef GENERICS
76import GHC.Generics
77import GHC.Generics
@@ -622,45 +623,66 @@ instance FromJSON UTCTime where
622 {-# INLINE parseJSON #-}
623 {-# INLINE parseJSON #-}
623
624
624instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
625instance (ToJSON a, ToJSON b) => ToJSON (a,b) where
625− toJSON (a,b) = toJSON [toJSON a, toJSON b]
626+ toJSON (a,b) = Array $ V.create $ do
627+ mv <- VM.unsafeNew 2
628+ VM.unsafeWrite mv 0 (toJSON a)
629+ VM.unsafeWrite mv 1 (toJSON b)
630+ return mv
626 {-# INLINE toJSON #-}
631 {-# INLINE toJSON #-}
627
632
628instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
633instance (FromJSON a, FromJSON b) => FromJSON (a,b) where
629− parseJSON (Array ab) =
634+ parseJSON (Array ab)
630− case V.toList ab of
635+ | n == 2 = (,) <$> parseJSON (V.unsafeIndex ab 0)
631− [a,b] -> (,) <$> parseJSON a <*> parseJSON b
636+ <*> parseJSON (V.unsafeIndex ab 1)
632− _ -> fail $ "cannot unpack array of length " ++
637+ | otherwise = fail $ "cannot unpack array of length " ++
633− show (V.length ab) ++ " into a pair"
638+ show n ++ " into a pair"
639+ where
640+ n = V.length ab
634− parseJSON v = typeMismatch "(a,b)" v
641+ parseJSON v = typeMismatch "(a,b)" v
635 {-# INLINE parseJSON #-}
642 {-# INLINE parseJSON #-}
636
643
637instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
644instance (ToJSON a, ToJSON b, ToJSON c) => ToJSON (a,b,c) where
638− toJSON (a,b,c) = toJSON [toJSON a, toJSON b, toJSON c]
645+ toJSON (a,b,c) = Array $ V.create $ do
646+ mv <- VM.unsafeNew 3
647+ VM.unsafeWrite mv 0 (toJSON a)
648+ VM.unsafeWrite mv 1 (toJSON b)
649+ VM.unsafeWrite mv 2 (toJSON c)
650+ return mv
639 {-# INLINE toJSON #-}
651 {-# INLINE toJSON #-}
640
652
641instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
653instance (FromJSON a, FromJSON b, FromJSON c) => FromJSON (a,b,c) where
642− parseJSON (Array abc) =
654+ parseJSON (Array abc)
643− case V.toList abc of
655+ | n == 3 = (,,) <$> parseJSON (V.unsafeIndex abc 0)
644− [a,b,c] -> (,,) <$> parseJSON a <*> parseJSON b <*> parseJSON c
656+ <*> parseJSON (V.unsafeIndex abc 1)
657+ <*> parseJSON (V.unsafeIndex abc 2)
645− _ -> fail $ "cannot unpack array of length " ++
658+ | otherwise = fail $ "cannot unpack array of length " ++
646− show (V.length abc) ++ " into a 3-tuple"
659+ show n ++ " into a 3-tuple"
660+ where
661+ n = V.length abc
647− parseJSON v = typeMismatch "(a,b,c)" v
662+ parseJSON v = typeMismatch "(a,b,c)" v
648 {-# INLINE parseJSON #-}
663 {-# INLINE parseJSON #-}
649
664
650instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
665instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSON (a,b,c,d) where
651− toJSON (a,b,c,d) = toJSON [toJSON a, toJSON b, toJSON c, toJSON d]
666+ toJSON (a,b,c,d) = Array $ V.create $ do
667+ mv <- VM.unsafeNew 4
668+ VM.unsafeWrite mv 0 (toJSON a)
669+ VM.unsafeWrite mv 1 (toJSON b)
670+ VM.unsafeWrite mv 2 (toJSON c)
671+ VM.unsafeWrite mv 3 (toJSON d)
672+ return mv
652 {-# INLINE toJSON #-}
673 {-# INLINE toJSON #-}
653
674
654instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
675instance (FromJSON a, FromJSON b, FromJSON c, FromJSON d) => FromJSON (a,b,c,d) where
655− parseJSON (Array abcd) =
676+ parseJSON (Array abcd)
656− case V.toList abcd of
657− [a,b,c,d] -> (,,,) <$> parseJSON a
677+ | n == 4 = (,,,) <$> parseJSON (V.unsafeIndex abcd 0)
658− <*> parseJSON b
678+ <*> parseJSON (V.unsafeIndex abcd 1)
659− <*> parseJSON c
679+ <*> parseJSON (V.unsafeIndex abcd 2)
660− <*> parseJSON d
680+ <*> parseJSON (V.unsafeIndex abcd 3)
661− _ -> fail $ "cannot unpack array of length " ++
681+ | otherwise = fail $ "cannot unpack array of length " ++
662− show (V.length abcd) ++ " into a 4-tuple"
682+ show n ++ " into a 4-tuple"
683+ where
684+ n = V.length abcd
663− parseJSON v = typeMismatch "(a,b,c,d)" v
685+ parseJSON v = typeMismatch "(a,b,c,d)" v
664 {-# INLINE parseJSON #-}
686 {-# INLINE parseJSON #-}
665
687
666instance ToJSON a => ToJSON (Dual a) where
688instance ToJSON a => ToJSON (Dual a) where
benchmarks/AesonTuples.hsnew file+45
@@ -0,0 +1,45 @@
1+module Main where
2+
3+--------------------------------------------------------------------------------
4+
5+import Criterion.Main
6+import Control.DeepSeq (deepseq)
7+import Data.Aeson
8+
9+--------------------------------------------------------------------------------
10+
11+type FJ a = Value -> Result a
12+
13+type T2 = (Int, Int)
14+type T3 = (Int, Int, Int)
15+type T4 = (Int, Int, Int, Int)
16+
17+t2 :: T2
18+t2 = (1, 2)
19+
20+t3 :: T3
21+t3 = (1, 2, 3)
22+
23+t4 :: T4
24+t4 = (1, 2, 3, 4)
25+
26+main :: IO ()
27+main = let v2 = toJSON t2
28+ v3 = toJSON t3
29+ v4 = toJSON t4
30+ in t2 `deepseq` t3 `deepseq` t4 `deepseq`
31+ v2 `deepseq` v3 `deepseq` v4 `deepseq`
32+ defaultMain
33+ [ bgroup "t2"
34+ [ bench "toJSON" (nf toJSON t2)
35+ , bench "fromJSON" (nf (fromJSON :: FJ T2) v2)
36+ ]
37+ , bgroup "t3"
38+ [ bench "toJSON" (nf toJSON t3)
39+ , bench "fromJSON" (nf (fromJSON :: FJ T3) v3)
40+ ]
41+ , bgroup "t4"
42+ [ bench "toJSON" (nf toJSON t4)
43+ , bench "fromJSON" (nf (fromJSON :: FJ T4) v4)
44+ ]
45+ ]