basvandijk avatar basvandijk committed 02f81e7

Improved performance of generic parseJSON of products
We first check if the length of the given array
equals the length of the product,
then we can unsafely index the array
which yields a nice performance improvement.
We are now faster than syb on the BigProduct benchmark.

Comments (0)

Files changed (1)

Data/Aeson/Types/Internal.hs

 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
 import Data.Typeable (Typeable)
-import Data.Vector (Vector, (!?))
+import Data.Vector (Vector)
 import Data.Word (Word, Word8, Word16, Word32, Word64)
 import Foreign.Storable (Storable)
 import System.Locale (defaultTimeLocale)
 class ConsToJSON    f where consToJSON  ::           f a -> Value
 class ConsToJSON' b f where consToJSON' :: Tagged b (f a -> Value)
 
+newtype Tagged s b = Tagged {unTagged :: b}
+
 instance (IsRecord f b, ConsToJSON' b f) => ConsToJSON f where
     consToJSON = unTagged (consToJSON' :: Tagged b (f a -> Value))
     {-# INLINE consToJSON #-}
     gParseJSON = fmap M1 . consParseJSON
     {-# INLINE gParseJSON #-}
 
-instance (GFromProduct a, GFromProduct b) => GFromJSON (a :*: b) where
-    gParseJSON (Array arr) = gParseProduct arr
+instance ( GFromProduct a, GFromProduct b
+         , ProductSize a, ProductSize b) => GFromJSON (a :*: b) where
+    gParseJSON (Array arr)
+        | lenArray == lenProduct = gParseProduct arr
+        | otherwise =
+            fail $ "When expecting a product of " ++ show lenProduct ++
+                   " values, encountered an Array of " ++ show lenArray ++
+                   " elements instead"
+        where
+          lenArray = V.length arr
+          lenProduct = unTagged2 (productSize :: Tagged2 (a :*: b) Int)
+
     gParseJSON v = typeMismatch "product (:*:)" v
     {-# INLINE gParseJSON #-}
 
 
 --------------------------------------------------------------------------------
 
+class ProductSize f where
+    productSize :: Tagged2 f Int
+
+newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
+
+instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
+    productSize = Tagged2 $ unTagged2 (productSize :: Tagged2 a Int) +
+                            unTagged2 (productSize :: Tagged2 b Int)
+
+instance ProductSize (S1 s a) where
+    productSize = Tagged2 1
+
+--------------------------------------------------------------------------------
+
 class GFromProduct f where
     gParseProduct :: Array -> Parser (f a)
 
           (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
     {-# INLINE gParseProduct #-}
 
-instance (GFromJSON a) => GFromProduct a where
-    gParseProduct ((!? 0) -> Just v) = gParseJSON v
-    gParseProduct _ = fail "Array to small"
+instance (GFromJSON a) => GFromProduct (S1 s a) where
+    gParseProduct arr = gParseJSON $ V.unsafeIndex arr 0
     {-# INLINE gParseProduct #-}
 
 --------------------------------------------------------------------------------
 
 notFound :: String -> Parser a
 notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
+{-# INLINE notFound #-}
 
 --------------------------------------------------------------------------------
 
-newtype Tagged s b = Tagged {unTagged :: b}
+class IsRecord (f :: * -> *) b | f -> b
 
 data True
 data False
 
-class IsRecord (f :: * -> *) b | f -> b
-
 instance (IsRecord f b) => IsRecord (f :*: g) b
 instance IsRecord (M1 S NoSelector f) False
 instance (IsRecord f b) => IsRecord (M1 S c f) b
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.