@@ -71,7 +71,7 @@ import Data.Text (Text, pack, unpack)
7171import Data.Time.Clock (UTCTime)
7272import Data.Time.Format (FormatTime, formatTime, parseTime)
7373import Data.Typeable (Typeable)
74−import Data.Vector (Vector, (!?))
74+import Data.Vector (Vector)
7575import Data.Word (Word, Word8, Word16, Word32, Word64)
7676import Foreign.Storable (Storable)
7777import System.Locale (defaultTimeLocale)
@@ -953,6 +953,8 @@ instance (GObject a, GObject b) => GToJSON (a :+: b) where
953953class ConsToJSON f where consToJSON :: f a -> Value
954954class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
955955
956+newtype Tagged s b = Tagged {unTagged :: b}
957+
956958instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
957959 consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
958960 {-# INLINE consToJSON #-}
@@ -1029,8 +1031,18 @@ instance (ConsFromJSON a) => GFromJSON (C1 c a) where
10291031 gParseJSON = fmap M1 . consParseJSON
10301032 {-# INLINE gParseJSON #-}
10311033
1032−instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
1033− gParseJSON (Array arr) = gParseProduct arr
1034+instance ( GFromProduct a, GFromProduct b
1035+ , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
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+
10341046 gParseJSON v = typeMismatch "product (:*:)" v
10351047 {-# INLINE gParseJSON #-}
10361048
@@ -1078,6 +1090,20 @@ instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
10781090
10791091--------------------------------------------------------------------------------
10801092
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+
10811107class GFromProduct f where
10821108 gParseProduct :: Array -> Parser (f a)
10831109
@@ -1087,9 +1113,8 @@ instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
10871113 (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
10881114 {-# INLINE gParseProduct #-}
10891115
1090−instance (GFromJSON a) => GFromProduct a where
1091− gParseProduct ((!? 0) -> Just v) = gParseJSON v
1092− gParseProduct _ = fail "Array to small"
1116+instance (GFromJSON a) => GFromProduct (S1 s a) where
1117+ gParseProduct arr = gParseJSON $ V.unsafeIndex arr 0
10931118 {-# INLINE gParseProduct #-}
10941119
10951120--------------------------------------------------------------------------------
@@ -1109,16 +1134,15 @@ instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
11091134
11101135notFound :: String -> Parser a
11111136notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
1137+{-# INLINE notFound #-}
11121138
11131139--------------------------------------------------------------------------------
11141140
1115−newtype Tagged s b = Tagged {unTagged :: b}
1141+class IsRecord (f :: * -> *) b | f -> b
11161142
11171143data True
11181144data False
11191145
1120−class IsRecord (f :: * -> *) b | f -> b
1121−
11221146instance (IsRecord f b) => IsRecord (f :*: g) b
11231147instance IsRecord (M1 S NoSelector f) False
11241148instance (IsRecord f b) => IsRecord (M1 S c f) b