git.iko.soy/typeable/aeson
on master help sign in
Improved performance of generic parseJSON of products
6c921cbBas van Dijk
Data/Aeson/Types/Internal.hs+33−9
compare with master
unifiedsplit
@@ -71,7 +71,7 @@ import Data.Text (Text, pack, unpack)
71import Data.Time.Clock (UTCTime)
71import Data.Time.Clock (UTCTime)
72import Data.Time.Format (FormatTime, formatTime, parseTime)
72import Data.Time.Format (FormatTime, formatTime, parseTime)
73import Data.Typeable (Typeable)
73import Data.Typeable (Typeable)
74−import Data.Vector (Vector, (!?))
74+import Data.Vector (Vector)
75import Data.Word (Word, Word8, Word16, Word32, Word64)
75import Data.Word (Word, Word8, Word16, Word32, Word64)
76import Foreign.Storable (Storable)
76import Foreign.Storable (Storable)
77import System.Locale (defaultTimeLocale)
77import System.Locale (defaultTimeLocale)
@@ -953,6 +953,8 @@ instance (GObject a, GObject b) => GToJSON (a :+: b) where
953class ConsToJSON f where consToJSON :: f a -> Value
953class ConsToJSON f where consToJSON :: f a -> Value
954class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
954class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
955
955
956+newtype Tagged s b = Tagged {unTagged :: b}
957+
956instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
958instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
957 consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
959 consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
958 {-# INLINE consToJSON #-}
960 {-# INLINE consToJSON #-}
@@ -1029,8 +1031,18 @@ instance (ConsFromJSON a) => GFromJSON (C1 c a) where
1029 gParseJSON = fmap M1 . consParseJSON
1031 gParseJSON = fmap M1 . consParseJSON
1030 {-# INLINE gParseJSON #-}
1032 {-# INLINE gParseJSON #-}
1031
1033
1032−instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
1034+instance ( GFromProduct a, GFromProduct b
1035+ , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
1033− gParseJSON (Array arr) = gParseProduct arr
1036+ gParseJSON (Array arr)
1037+ | lenArray == lenProduct = gParseProduct arr
1038+ | otherwise =
1039+ fail $ "When expecting a product of " ++ show lenProduct ++
1040+ " values, encountered an Array of " ++ show lenArray ++
1041+ " elements instead"
1042+ where
1043+ lenArray = V.length arr
1044+ lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
1045+
1034 gParseJSON v = typeMismatch "product (:*:)" v
1046 gParseJSON v = typeMismatch "product (:*:)" v
1035 {-# INLINE gParseJSON #-}
1047 {-# INLINE gParseJSON #-}
1036
1048
@@ -1078,6 +1090,20 @@ instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
1078
1090
1079--------------------------------------------------------------------------------
1091--------------------------------------------------------------------------------
1080
1092
1093+class ProductSize f where
1094+ productSize :: Tagged2 f Int
1095+
1096+newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
1097+
1098+instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
1099+ productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
1100+ unTagged2 (productSize :: Tagged2 b Int)
1101+
1102+instance ProductSize (S1 s a) where
1103+ productSize = Tagged2 1
1104+
1105+--------------------------------------------------------------------------------
1106+
1081class GFromProduct f where
1107class GFromProduct f where
1082 gParseProduct :: Array -> Parser (f a)
1108 gParseProduct :: Array -> Parser (f a)
1083
1109
@@ -1087,9 +1113,8 @@ instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
1087 (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
1113 (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
1088 {-# INLINE gParseProduct #-}
1114 {-# INLINE gParseProduct #-}
1089
1115
1090−instance (GFromJSON a) => GFromProduct a where
1116+instance (GFromJSON a) => GFromProduct (S1 s a) where
1091− gParseProduct ((!? 0) -> Just v) = gParseJSON v
1117+ gParseProduct arr = gParseJSON $ V.unsafeIndex arr 0
1092− gParseProduct _ = fail "Array to small"
1093 {-# INLINE gParseProduct #-}
1118 {-# INLINE gParseProduct #-}
1094
1119
1095--------------------------------------------------------------------------------
1120--------------------------------------------------------------------------------
@@ -1109,16 +1134,15 @@ instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
1109
1134
1110notFound :: String -> Parser a
1135notFound :: String -> Parser a
1111notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1136notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1137+{-# INLINE notFound #-}
1112
1138
1113--------------------------------------------------------------------------------
1139--------------------------------------------------------------------------------
1114
1140
1115−newtype Tagged s b = Tagged {unTagged :: b}
1141+class IsRecord (f :: * -> *) b | f -> b
1116
1142
1117data True
1143data True
1118data False
1144data False
1119
1145
1120−class IsRecord (f :: * -> *) b | f -> b
1121−
1122instance (IsRecord f b) => IsRecord (f :*: g) b
1146instance (IsRecord f b) => IsRecord (f :*: g) b
1123instance IsRecord (M1 S NoSelector f) False
1147instance IsRecord (M1 S NoSelector f) False
1124instance (IsRecord f b) => IsRecord (M1 S c f) b
1148instance (IsRecord f b) => IsRecord (M1 S c f) b