Commits

Bryan O'Sullivan committed c8bf2e7 Merge

Merge pull request #36 from basvandijk/optimizations

Optimizations

  • Participants
  • Parent commits a6c7d60, fca9f59

Comments (0)

Files changed (6)

File Data/Aeson/TH.hs

                         case conVal of
                           'Array' arr ->
                             if V.length arr == 3
-                            then Product \<$\> 'parseJSON' (arr V.! 0)
-                                         \<*\> 'parseJSON' (arr V.! 1)
-                                         \<*\> 'parseJSON' (arr V.! 2)
+                            then Product \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
+                                         \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
+                                         \<*\> 'parseJSON' (arr `V.unsafeIndex` 2)
                             else fail \"\<error message\>\"
                           _ -> fail \"\<error message\>\"
                     | conKey == T.pack \"Record\" ->
 import Text.Printf         ( printf )
 import Text.Show           ( show )
 #if __GLASGOW_HASKELL__ < 700
-import Control.Monad       ( (>>=) )
+import Control.Monad       ( (>>=), fail )
 import Prelude             ( fromInteger )
 #endif
 -- from containers:
 -- from text:
 import qualified Data.Text as T ( Text, pack, unpack )
 -- from vector:
-import qualified Data.Vector as V ( (!), null, length )
+import qualified Data.Vector as V ( unsafeIndex, null, length )
 
 
 
 --         \value -> case value of
 --                     'Array' arr ->
 --                       if (V.length arr == 2)
---                       then Foo \<$\> 'parseJSON' (arr V.! 0)
---                                \<*\> 'parseJSON' (arr V.! 1)
+--                       then Foo \<$\> 'parseJSON' (arr `V.unsafeIndex` 0)
+--                                \<*\> 'parseJSON' (arr `V.unsafeIndex` 1)
 --                       else fail \"\<error message\>\"
 --                     other -> fail \"\<error message\>\"
 -- @
              -> [Q Match]
 parseProduct tName conName numArgs =
     [ do arr <- newName "arr"
-         -- List of: "parseJSON (arr V.! <IX>)"
+         -- List of: "parseJSON (arr `V.unsafeIndex` <IX>)"
          let x:xs = [ [|parseJSON|]
                       `appE`
                       infixApp (varE arr)
-                               [|(V.!)|]
+                               [|V.unsafeIndex|]
                                (litE $ integerL ix)
                     | ix <- [0 .. numArgs - 1]
                     ]

File Data/Aeson/Types/Class.hs

-{-# LANGUAGE CPP, DeriveDataTypeable, FlexibleContexts, FlexibleInstances,
-    GeneralizedNewtypeDeriving, IncoherentInstances, OverlappingInstances,
-    OverloadedStrings, UndecidableInstances, ViewPatterns #-}
+{-# LANGUAGE CPP
+           , DeriveDataTypeable
+           , FlexibleContexts
+           , FlexibleInstances
+           , GeneralizedNewtypeDeriving
+           , OverlappingInstances
+           , OverloadedStrings
+           , UndecidableInstances
+           , ViewPatterns
+  #-}
 
 #ifdef GENERICS
 {-# LANGUAGE DefaultSignatures #-}
 --
 -- * 'Data.Aeson.Generic' provides a generic @toJSON@ function that accepts any
 -- type which is an instance of 'Data'.
--- 
+--
 -- * If your compiler has support for the @DeriveGeneric@ and
 -- @DefaultSignatures@ language extensions, @toJSON@ will have a default generic
 -- implementation.
 -- @{-\# LANGUAGE OverloadedStrings #-}
 --
 -- data Coord { x :: Double, y :: Double }
--- 
+--
 -- instance FromJSON Coord where
 --   parseJSON ('Object' v) = Coord    '<$>'
 --                          v '.:' \"x\" '<*>'

File Data/Aeson/Types/Generic.hs

-{-# LANGUAGE DefaultSignatures, EmptyDataDecls, FlexibleContexts,
-    FlexibleInstances, FunctionalDependencies, IncoherentInstances,
-    KindSignatures, OverlappingInstances, ScopedTypeVariables, TypeOperators,
-    UndecidableInstances, ViewPatterns #-}
+{-# LANGUAGE DefaultSignatures
+           , EmptyDataDecls
+           , FlexibleInstances
+           , FunctionalDependencies
+           , KindSignatures
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , TypeOperators
+           , UndecidableInstances
+           , ViewPatterns
+  #-}
+
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 -- |
 
 import Control.Applicative
 import Control.Monad.State.Strict
+import Data.Bits (shiftR)
 import Data.Aeson.Types.Class
 import Data.Aeson.Types.Internal
 import Data.Text (pack, unpack)
-import Data.Vector ((!?))
 import GHC.Generics
 import qualified Data.Map as M
 import qualified Data.Text as T
 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 #-}
     {-# INLINE gObject #-}
 
 instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
-    gObject m1 = M.singleton (pack (conName m1)) (gToJSON m1)
+    gObject = M.singleton (pack $ conName (undefined :: t c a p)) . gToJSON
     {-# INLINE gObject #-}
 
 --------------------------------------------------------------------------------
     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 0 lenProduct
+        | 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 #-}
 
 instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
-    gParseJSON (Object (M.toList -> [keyVal])) = gParseSum keyVal
+    gParseJSON (Object (M.toList -> [keyVal@(key, _)])) =
+        case gParseSum keyVal of
+          Nothing -> notFound $ unpack key
+          Just p  -> p
     gParseJSON v = typeMismatch "sum (:+:)" v
     {-# INLINE gParseJSON #-}
 
+notFound :: String -> Parser a
+notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
+{-# INLINE notFound #-}
+
 --------------------------------------------------------------------------------
 
 class ConsFromJSON    f where consParseJSON  ::           Value -> Parser (f a)
     {-# INLINE gParseRecord #-}
 
 instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
-    gParseRecord obj = case M.lookup (T.pack key) obj of
-                         Nothing -> notFound key
-                         Just v  -> gParseJSON v
+    gParseRecord = maybe (notFound key) gParseJSON . M.lookup (T.pack key)
         where
           key = selName (undefined :: t s a p)
     {-# INLINE gParseRecord #-}
 
 --------------------------------------------------------------------------------
 
+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)
+    gParseProduct :: Array -> Int -> Int -> Parser (f a)
 
 instance (GFromProduct a, GFromProduct b) => GFromProduct (a :*: b) where
-    gParseProduct arr = (:*:) <$> gParseProduct arrL <*> gParseProduct arrR
+    gParseProduct arr ix len = (:*:) <$> gParseProduct arr ix  lenL
+                                     <*> gParseProduct arr ixR lenR
         where
-          (arrL, arrR) = V.splitAt (V.length arr `div` 2) arr
+          lenL = len `shiftR` 1
+          ixR  = ix + lenL
+          lenR = len - lenL
     {-# 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 ix _ = gParseJSON $ V.unsafeIndex arr ix
     {-# INLINE gParseProduct #-}
 
 --------------------------------------------------------------------------------
 
 class GFromSum f where
-    gParseSum :: Pair -> Parser (f a)
+    gParseSum :: Pair -> Maybe (Parser (f a))
 
 instance (GFromSum a, GFromSum b) => GFromSum (a :+: b) where
-    gParseSum keyVal = (L1 <$> gParseSum keyVal) <|> (R1 <$> gParseSum keyVal)
+    gParseSum keyVal = (fmap L1 <$> gParseSum keyVal) <|>
+                       (fmap R1 <$> gParseSum keyVal)
     {-# INLINE gParseSum #-}
 
 instance (Constructor c, GFromJSON a, ConsFromJSON a) => GFromSum (C1 c a) where
     gParseSum (key, value)
-        | key == pack (conName (undefined :: t c a p)) = gParseJSON value
-        | otherwise = notFound $ unpack key
+        | key == pack (conName (undefined :: t c a p)) = Just $ gParseJSON value
+        | otherwise = Nothing
     {-# INLINE gParseSum #-}
 
-notFound :: String -> Parser a
-notFound key = fail $ "The key \"" ++ key ++ "\" was not found"
-
 --------------------------------------------------------------------------------
 
-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

File Data/Aeson/Types/Internal.hs

-{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving,
-    IncoherentInstances, OverlappingInstances, OverloadedStrings, Rank2Types,
-    ViewPatterns, FlexibleContexts, UndecidableInstances,
-    ScopedTypeVariables, PatternGuards #-}
-
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, Rank2Types #-}
 
 -- |
 -- Module:      Data.Aeson.Types.Internal
     Data.Aeson.Types.Internal
 
   if impl(ghc >= 7.2.1)
+    cpp-options: -DGENERICS
+    build-depends: ghc-prim >= 0.2
     other-modules:
       Data.Aeson.Types.Generic
 
     ghc-options: -Werror
     ghc-prof-options: -auto-all
 
-  if impl(ghc >= 7.2.1)
-    cpp-options: -DGENERICS
-    build-depends: ghc-prim >= 0.2
-
   ghc-options:      -Wall
 
 test-suite tests

File benchmarks/AesonCompareAutoInstances.hs

          | Record { testOne   :: Double
                   , testTwo   :: Bool
                   , testThree :: D a
-                  } deriving (Eq, Generic, Data, Typeable)
+                  } deriving (Show, Eq, Generic, Data, Typeable)
 
 instance NFData a => NFData (D a) where
     rnf Nullary         = ()
 --------------------------------------------------------------------------------
 
 data BigRecord = BigRecord
-    { field01 :: !(), field02 :: !(), field03 :: !(), field04 :: !(), field05 :: !()
-    , field06 :: !(), field07 :: !(), field08 :: !(), field09 :: !(), field10 :: !()
-    , field11 :: !(), field12 :: !(), field13 :: !(), field14 :: !(), field15 :: !()
-    , field16 :: !(), field17 :: !(), field18 :: !(), field19 :: !(), field20 :: !()
-    , field21 :: !(), field22 :: !(), field23 :: !(), field24 :: !(), field25 :: !()
-    } deriving (Eq, Generic, Data, Typeable)
+    { field01 :: !Int, field02 :: !Int, field03 :: !Int, field04 :: !Int, field05 :: !Int
+    , field06 :: !Int, field07 :: !Int, field08 :: !Int, field09 :: !Int, field10 :: !Int
+    , field11 :: !Int, field12 :: !Int, field13 :: !Int, field14 :: !Int, field15 :: !Int
+    , field16 :: !Int, field17 :: !Int, field18 :: !Int, field19 :: !Int, field20 :: !Int
+    , field21 :: !Int, field22 :: !Int, field23 :: !Int, field24 :: !Int, field25 :: !Int
+    } deriving (Show, Eq, Generic, Data, Typeable)
 
 instance NFData BigRecord
 
-bigRecord = BigRecord () () () () ()
-                      () () () () ()
-                      () () () () ()
-                      () () () () ()
-                      () () () () ()
+bigRecord = BigRecord 1   2  3  4  5
+                      6   7  8  9 10
+                      11 12 13 14 15
+                      16 17 18 19 20
+                      21 22 23 24 25
 
 instance ToJSON   BigRecord
 instance FromJSON BigRecord
 --------------------------------------------------------------------------------
 
 data BigProduct = BigProduct
-    !() !() !() !() !()
-    !() !() !() !() !()
-    !() !() !() !() !()
-    !() !() !() !() !()
-    !() !() !() !() !()
-    deriving (Eq, Generic, Data, Typeable)
+    !Int !Int !Int !Int !Int
+    !Int !Int !Int !Int !Int
+    !Int !Int !Int !Int !Int
+    !Int !Int !Int !Int !Int
+    !Int !Int !Int !Int !Int
+    deriving (Show, Eq, Generic, Data, Typeable)
 
 instance NFData BigProduct
 
-bigProduct = BigProduct () () () () ()
-                        () () () () ()
-                        () () () () ()
-                        () () () () ()
-                        () () () () ()
+bigProduct = BigProduct 1   2  3  4  5
+                        6   7  8  9 10
+                        11 12 13 14 15
+                        16 17 18 19 20
+                        21 22 23 24 25
 
 instance ToJSON   BigProduct
 instance FromJSON BigProduct
             | F11 | F12 | F13 | F14 | F15
             | F16 | F17 | F18 | F19 | F20
             | F21 | F22 | F23 | F24 | F25
-    deriving (Eq, Generic, Data, Typeable)
+    deriving (Show, Eq, Generic, Data, Typeable)
 
 instance NFData BigSum
 
-bigSum = F12
+bigSum = F25
 
 instance ToJSON   BigSum
 instance FromJSON BigSum