Commits

basvandijk committed 08f413e

Use HashMap instead of Map for Objects
This gives some nice speedups in the AesonCompareAutoInstances benchmarks:
24.7% speedup on average
98.0% maximum speedup
-1.7% maximum slowdown

  • Participants
  • Parent commits a287d10

Comments (0)

Files changed (8)

File Data/Aeson/Encode.hs

 import Numeric (showHex)
 import Blaze.Text (double, integral)
 import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.Map as M
+import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Vector as V
 
                   V.foldr f (fromChar ']') (V.unsafeTail v)
   where f a z = fromChar ',' `mappend` fromValue a `mappend` z
 fromValue (Object m) =
-    case M.toList m of
+    case H.toList m of
       (x:xs) -> fromChar '{' `mappend`
                 one x `mappend`
                 foldr f (fromChar '}') xs

File Data/Aeson/Functions.hs

 module Data.Aeson.Functions
-    (
-      hashMap
-    , mapHash
-    , transformMap
+    ( mapHashKeyVal
+    , hashMapKey
+    , mapKeyVal
+    , mapKey
     -- * String conversions
     , decode
     , strict
     , lazy
     ) where
 
-import Control.Arrow ((***), first)
 import Data.Hashable (Hashable)
 import Data.Text (Text)
 import Data.Text.Encoding (decodeUtf8, encodeUtf8)
 import qualified Data.HashMap.Strict as H
 import qualified Data.Map as M
 
--- | Transform one map into another.  The ordering of keys must be
--- preserved by the key transformation function.
-transformMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2)
-             -> M.Map k1 v1 -> M.Map k2 v2
-transformMap fk fv = M.fromAscList . map (fk *** fv) . M.toAscList
-{-# INLINE transformMap #-}
+-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.
+mapHashKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
+              -> M.Map k1 v1 -> H.HashMap k2 v2
+mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
+{-# INLINE mapHashKeyVal #-}
 
--- | Transform a 'H.HashMap' into a 'M.Map'.
-hashMap :: (Ord k2) => (k1 -> k2) -> (v1 -> v2)
-        -> H.HashMap k1 v1 -> M.Map k2 v2
-hashMap fk kv = M.fromList . map (fk *** kv) . H.toList
-{-# INLINE hashMap #-}
+-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.
+hashMapKey :: (Ord k2) => (k1 -> k2)
+           -> H.HashMap k1 v -> M.Map k2 v
+hashMapKey kv = H.foldrWithKey (M.insert . kv) M.empty
+{-# INLINE hashMapKey #-}
 
--- | Transform a 'M.Map' into a 'H.HashMap'.
-mapHash :: (Eq k2, Hashable k2) => (k1 -> k2) -> M.Map k1 v -> H.HashMap k2 v
-mapHash fk = H.fromList . map (first fk) . M.toList
-{-# INLINE mapHash #-}
+-- | Transform the keys and values of a 'H.HashMap'.
+mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
+          -> H.HashMap k1 v1 -> H.HashMap k2 v2
+mapKeyVal fk kv = H.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
+{-# INLINE mapKeyVal #-}
+
+-- | Transform the keys of a 'H.HashMap'.
+mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> H.HashMap k1 v -> H.HashMap k2 v
+mapKey fk = mapKeyVal fk id
+{-# INLINE mapKey #-}
 
 strict :: L.ByteString -> Text
 strict = decode . B.concat . L.toChunks

File Data/Aeson/Generic.hs

       | otherwise = modError "toJSON" $
                              "cannot convert map keyed by type " ++ show tyrep
       where tyrep = typeOf . head . Map.keys $ m
-            remap f = Object . transformMap (f . fromJust . cast) toJSON $ m
+            remap f = Object . mapHashKeyVal (f . fromJust . cast) toJSON $ m
 
     hashMapAny m
       | tyrep == typeOf DT.empty = remap id
       | otherwise = modError "toJSON" $
                              "cannot convert map keyed by type " ++ show tyrep
       where tyrep = typeOf . head . H.keys $ m
-            remap f = Object . hashMap (f . fromJust . cast) toJSON $ m
+            remap f = Object . mapKeyVal (f . fromJust . cast) toJSON $ m
 
 
 -- Skip leading '_' in field name so we can use keywords
     vector = case j of
                Array js -> V.mapM parseJSON js
                _        -> myFail
+
     mapAny :: forall e f. (Data e, Data f) => Parser (Map.Map f e)
     mapAny
-        | tyrep `elem` stringyTypes = res
+        | tyrep == typeOf DT.empty = process id
+        | tyrep == typeOf LT.empty = process LT.fromStrict
+        | tyrep == typeOf ""       = process DT.unpack
+        | tyrep == typeOf B.empty  = process encodeUtf8
+        | tyrep == typeOf L.empty  = process lazy
         | otherwise = myFail
-      where res = case j of
-                Object js -> Map.mapKeysMonotonic trans <$> T.mapM parseJSON js
-                _         -> myFail
-            trans
-               | tyrep == typeOf DT.empty = remap id
-               | tyrep == typeOf LT.empty = remap LT.fromStrict
-               | tyrep == typeOf ""       = remap DT.unpack
-               | tyrep == typeOf B.empty  = remap encodeUtf8
-               | tyrep == typeOf L.empty  = remap lazy
-               | otherwise = modError "parseJSON"
-                                      "mapAny -- should never happen"
-            tyrep = typeOf (undefined :: f)
-            remap f = fromJust . cast . f
+        where
+          process f = maybe myFail return . cast =<< parseWith f
+          parseWith :: (Ord c) => (Text -> c) -> Parser (Map.Map c e)
+          parseWith f = case j of
+                          Object js -> Map.fromList . map (first f) . H.toList <$>
+                                         T.mapM parseJSON js
+                          _         -> myFail
+          tyrep = typeOf (undefined :: f)
+
     hashMapAny :: forall e f. (Data e, Data f) => Parser (H.HashMap f e)
     hashMapAny
+        | tyrep == typeOf DT.empty = process id
+        | tyrep == typeOf LT.empty = process LT.fromStrict
         | tyrep == typeOf ""       = process DT.unpack
-        | tyrep == typeOf LT.empty = process LT.fromStrict
-        | tyrep == typeOf DT.empty = process id
+        | tyrep == typeOf B.empty  = process encodeUtf8
+        | tyrep == typeOf L.empty  = process lazy
         | otherwise = myFail
       where
         process f = maybe myFail return . cast =<< parseWith f
         parseWith :: (Eq c, Hashable c) => (Text -> c) -> Parser (H.HashMap c e)
         parseWith f = case j of
-                        Object js -> H.fromList . map (first f) . Map.toList <$>
-                                     T.mapM parseJSON js
-                        _          -> myFail
+                        Object js -> mapKey f <$> T.mapM parseJSON js
+                        _         -> myFail
         tyrep = typeOf (undefined :: f)
+
     myFail = modFail "parseJSON" $ "bad data: " ++ show j
-    stringyTypes = [typeOf LT.empty, typeOf DT.empty, typeOf B.empty,
-                    typeOf L.empty, typeOf ""]
 
 parseJSON_generic :: (Data a) => Value -> Parser a
 parseJSON_generic j = generic
           go _ c _        jd         = modFail "parseJSON" $
                                        "bad decodeArgs data " ++ show (c, jd)
 
-        fromJSObject = map (first unpack) . Map.toList
+        fromJSObject = map (first unpack) . H.toList
 
         -- Build the value by stepping through the list of subparts.
         construct c = evalStateT $ fromConstrM f c
         -- Select the named fields from a JSON object.
         selectFields fjs = mapM sel
           where sel f = maybe (modFail "parseJSON" $ "field does not exist " ++
-                               f) return $ Map.lookup (mungeField f) fjs
+                               f) return $ H.lookup (mungeField f) fjs
 
         -- Count how many arguments a constructor has.  The value x is
         -- used to determine what type the constructor returns.

File Data/Aeson/Parser.hs

 import Data.Bits ((.|.), shiftL)
 import Data.ByteString as B
 import Data.Char (chr)
-import Data.Map as Map
 import Data.Monoid (mappend, mempty)
 import Data.Text as T
 import Data.Text.Encoding (decodeUtf8)
 import qualified Data.Attoparsec.Zepto as Z
 import qualified Data.ByteString.Char8 as B8
 import qualified Data.ByteString.Unsafe as B
+import qualified Data.HashMap.Strict as H
 
 -- | Parse a top-level JSON value.  This must be either an object or
 -- an array.
         b <- char ':' *> skipSpace *> value
         return (a,b)
   vals <- ((pair <* skipSpace) `sepBy` (char ',' *> skipSpace)) <* char '}'
-  return . Object $ Map.fromList vals
+  return . Object $ H.fromList vals
 
 array_ :: Parser Value
 array_ = {-# SCC "array_" #-} do

File Data/Aeson/TH.hs

       \value ->
         case value of
           'Object' obj ->
-            case M.toList obj of
+            case H.toList obj of
               [(conKey, conVal)] ->
                 case conKey of
                   _ | conKey == T.pack \"Nullary\" ->
                     | conKey == T.pack \"Record\" ->
                         case conVal of
                           'Object' recObj ->
-                            if M.size recObj == 3
+                            if H.size recObj == 3
                             then Record \<$\> recObj '.:' T.pack \"One\"
                                         \<*\> recObj '.:' T.pack \"Two\"
                                         \<*\> recObj '.:' T.pack \"Three\"
 import Control.Monad       ( (>>=) )
 import Prelude             ( fromInteger )
 #endif
--- from containers:
-import qualified Data.Map as M ( lookup, toList, size )
+-- from unordered-containers:
+import qualified Data.HashMap.Strict as H ( lookup, toList, size )
 -- from template-haskell:
 import Language.Haskell.TH
 -- from text:
   let -- Convert the Data.Map inside the Object to a list and pattern match
       -- against it. It must contain a single element otherwise the parse will
       -- fail.
-      caseLst = caseE ([e|M.toList|] `appE` varE obj)
+      caseLst = caseE ([e|H.toList|] `appE` varE obj)
                       [ match (listP [tupP [varP conKey, varP conVal]])
                               (normalB caseKey)
                               []
                     | (field, _, _) <- ts
                     ]
          match (conP 'Object [varP obj])
-               ( normalB $ condE ( infixApp ([|M.size|] `appE` varE obj)
+               ( normalB $ condE ( infixApp ([|H.size|] `appE` varE obj)
                                             [|(==)|]
                                             (litE $ integerL $ genericLength ts)
                                  )
                                                         ++ show (length ts)
                                                         ++ " name/value pairs"
                                      )
-                                     ( infixApp ([|show . M.size|] `appE` varE obj)
+                                     ( infixApp ([|show . H.size|] `appE` varE obj)
                                                 [|(++)|]
                                                 (litE $ stringL $ " name/value pairs")
                                      )
 
 lookupField :: (FromJSON a) => String -> String -> Object -> T.Text -> Parser a
 lookupField tName rec obj key =
-    case M.lookup key obj of
+    case H.lookup key obj of
       Nothing -> unknownFieldFail tName rec (T.unpack key)
       Just v  -> parseJSON v
 

File Data/Aeson/Types/Class.hs

 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock (UTCTime)
 import Data.Time.Format (FormatTime, formatTime, parseTime)
+import Data.Traversable (traverse)
 import Data.Typeable (Typeable)
 import Data.Vector (Vector)
 import Data.Word (Word, Word8, Word16, Word32, Word64)
     {-# INLINE toJSON #-}
 
 instance (FromJSON a, FromJSON b) => FromJSON (Either a b) where
-    parseJSON (Object (M.toList -> [(key, value)]))
+    parseJSON (Object (H.toList -> [(key, value)]))
         | key == left  = Left  <$> parseJSON value
         | key == right = Right <$> parseJSON value
     parseJSON _        = fail ""
     {-# INLINE parseJSON #-}
 
 instance (ToJSON v) => ToJSON (M.Map Text v) where
-    toJSON = Object . M.map toJSON
+    toJSON = Object . M.foldrWithKey (\k -> H.insert k . toJSON) H.empty
     {-# INLINE toJSON #-}
 
 instance (FromJSON v) => FromJSON (M.Map Text v) where
-    parseJSON (Object o) = M.fromAscList <$> mapM go (M.toAscList o)
-      where go (k,v)     = ((,) k) <$> parseJSON v
+    parseJSON (Object o) = H.foldrWithKey M.insert M.empty <$> traverse parseJSON o
     parseJSON v          = typeMismatch "Map Text a" v
 
 instance (ToJSON v) => ToJSON (M.Map LT.Text v) where
-    toJSON = Object . transformMap LT.toStrict toJSON
+    toJSON = Object . mapHashKeyVal LT.toStrict toJSON
 
 instance (FromJSON v) => FromJSON (M.Map LT.Text v) where
-    parseJSON = fmap (M.mapKeysMonotonic LT.fromStrict) . parseJSON
+    parseJSON = fmap (hashMapKey LT.fromStrict) . parseJSON
 
 instance (ToJSON v) => ToJSON (M.Map String v) where
-    toJSON = Object . transformMap pack toJSON
+    toJSON = Object . mapHashKeyVal pack toJSON
 
 instance (FromJSON v) => FromJSON (M.Map String v) where
-    parseJSON = fmap (M.mapKeysMonotonic unpack) . parseJSON
+    parseJSON = fmap (hashMapKey unpack) . parseJSON
 
 instance (ToJSON v) => ToJSON (M.Map B.ByteString v) where
-    toJSON = Object . transformMap decode toJSON
+    toJSON = Object . mapHashKeyVal decode toJSON
 
 instance (FromJSON v) => FromJSON (M.Map B.ByteString v) where
-    parseJSON = fmap (M.mapKeysMonotonic encodeUtf8) . parseJSON
+    parseJSON = fmap (hashMapKey encodeUtf8) . parseJSON
 
 instance (ToJSON v) => ToJSON (M.Map LB.ByteString v) where
-    toJSON = Object . transformMap strict toJSON
+    toJSON = Object . mapHashKeyVal strict toJSON
 
 instance (FromJSON v) => FromJSON (M.Map LB.ByteString v) where
-    parseJSON = fmap (M.mapKeysMonotonic lazy) . parseJSON
+    parseJSON = fmap (hashMapKey lazy) . parseJSON
 
 instance (ToJSON v) => ToJSON (H.HashMap Text v) where
-    toJSON = Object . hashMap id toJSON
+    toJSON = Object . H.map toJSON
     {-# INLINE toJSON #-}
 
 instance (FromJSON v) => FromJSON (H.HashMap Text v) where
-    parseJSON (Object o) = H.fromList <$> mapM go (M.toList o)
-      where go (k,v)     = ((,) k) <$> parseJSON v
+    parseJSON (Object o) = traverse parseJSON o
     parseJSON v          = typeMismatch "HashMap Text a" v
 
 instance (ToJSON v) => ToJSON (H.HashMap LT.Text v) where
-    toJSON = Object . M.fromList . H.foldrWithKey (\k v -> ((LT.toStrict k,toJSON v) :)) []
+    toJSON = Object . mapKeyVal LT.toStrict toJSON
 
 instance (FromJSON v) => FromJSON (H.HashMap LT.Text v) where
-    parseJSON = fmap (mapHash LT.fromStrict) . parseJSON
+    parseJSON = fmap (mapKey LT.fromStrict) . parseJSON
 
 instance (ToJSON v) => ToJSON (H.HashMap String v) where
-    toJSON = Object . hashMap pack toJSON
+    toJSON = Object . mapKeyVal pack toJSON
 
 instance (FromJSON v) => FromJSON (H.HashMap String v) where
-    parseJSON = fmap (mapHash unpack) . parseJSON
+    parseJSON = fmap (mapKey unpack) . parseJSON
 
 instance (ToJSON v) => ToJSON (H.HashMap B.ByteString v) where
-    toJSON = Object . hashMap decode toJSON
+    toJSON = Object . mapKeyVal decode toJSON
 
 instance (FromJSON v) => FromJSON (H.HashMap B.ByteString v) where
-    parseJSON = fmap (mapHash encodeUtf8) . parseJSON
+    parseJSON = fmap (mapKey encodeUtf8) . parseJSON
 
 instance (ToJSON v) => ToJSON (H.HashMap LB.ByteString v) where
-    toJSON = Object . hashMap strict toJSON
+    toJSON = Object . mapKeyVal strict toJSON
 
 instance (FromJSON v) => FromJSON (H.HashMap LB.ByteString v) where
-    parseJSON = fmap (mapHash lazy) . parseJSON
+    parseJSON = fmap (mapKey lazy) . parseJSON
 
 instance ToJSON Value where
     toJSON a = a
 -- in an object for it to be valid.  If the key and value are
 -- optional, use '(.:?)' instead.
 (.:) :: (FromJSON a) => Object -> Text -> Parser a
-obj .: key = case M.lookup key obj of
+obj .: key = case H.lookup key obj of
                Nothing -> fail $ "key " ++ show key ++ " not present"
                Just v  -> parseJSON v
 {-# INLINE (.:) #-}
 -- from an object without affecting its validity.  If the key and
 -- value are mandatory, use '(.:)' instead.
 (.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a)
-obj .:? key = case M.lookup key obj of
+obj .:? key = case H.lookup key obj of
                Nothing -> pure Nothing
                Just v  -> parseJSON v
 {-# INLINE (.:?) #-}

File Data/Aeson/Types/Generic.hs

 import Data.Aeson.Types.Internal
 import Data.Text (pack, unpack)
 import GHC.Generics
-import qualified Data.Map as M
+import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Vector as V
 
     {-# INLINE gObject #-}
 
 instance (Constructor c, GToJSON a, ConsToJSON a) => GObject (C1 c a) where
-    gObject = M.singleton (pack $ conName (undefined :: t c a p)) . gToJSON
+    gObject = H.singleton (pack $ conName (undefined :: t c a p)) . gToJSON
     {-# INLINE gObject #-}
 
 --------------------------------------------------------------------------------
     {-# INLINE gParseJSON #-}
 
 instance (GFromSum a, GFromSum b) => GFromJSON (a :+: b) where
-    gParseJSON (Object (M.toList -> [keyVal@(key, _)])) =
+    gParseJSON (Object (H.toList -> [keyVal@(key, _)])) =
         case gParseSum keyVal of
           Nothing -> notFound $ unpack key
           Just p  -> p
     {-# INLINE gParseRecord #-}
 
 instance (Selector s, GFromJSON a) => GFromRecord (S1 s a) where
-    gParseRecord = maybe (notFound key) gParseJSON . M.lookup (T.pack key)
+    gParseRecord = maybe (notFound key) gParseJSON . H.lookup (T.pack key)
         where
           key = selName (undefined :: t s a p)
     {-# INLINE gParseRecord #-}

File Data/Aeson/Types/Internal.hs

 import Control.DeepSeq (NFData(..))
 import Control.Monad.State.Strict
 import Data.Attoparsec.Char8 (Number(..))
-import Data.Data (Data)
 import Data.Hashable (Hashable(..))
-import Data.List (foldl')
-import Data.Map (Map)
+import Data.HashMap.Strict (HashMap)
 import Data.Monoid (Monoid(..))
 import Data.String (IsString(..))
 import Data.Text (Text, pack)
 import Data.Typeable (Typeable)
 import Data.Vector (Vector)
-import qualified Data.Map as M
+import qualified Data.HashMap.Strict as H
 import qualified Data.Vector as V
 
 -- | The result of running a 'Parser'.
 {-# INLINE apP #-}
 
 -- | A JSON \"object\" (key\/value map).
-type Object = Map Text Value
+type Object = HashMap Text Value
 
 -- | A JSON \"array\" (sequence).
 type Array = Vector Value
            | Number Number
            | Bool !Bool
            | Null
-             deriving (Eq, Show, Typeable, Data)
+             deriving (Eq, Show, Typeable)
 
 instance NFData Value where
-    rnf (Object o) = obj_rnf o
+    rnf (Object o) = rnf o
     rnf (Array a)  = V.foldl' (\x y -> rnf y `seq` x) () a
     rnf (String s) = rnf s
     rnf (Number n) = case n of I i -> rnf i; D d -> rnf d
     rnf (Bool b)   = rnf b
     rnf Null       = ()
 
-obj_rnf :: (NFData k, NFData v) => Map k v -> ()
-#if MIN_VERSION_containers(0,4,2)
-obj_rnf = rnf
-#elif MIN_VERSION_containers(0,4,1)
-obj_rnf = M.foldlWithKey' (\_ k v -> rnf k `seq` rnf v) ()
-#else
-obj_rnf = rnf . M.toList
-#endif
-
 instance IsString Value where
     fromString = String . pack
     {-# INLINE fromString #-}
 
 instance Hashable Value where
-    hash (Object o) = foldl' hashWithSalt 0 . M.toList $ o
+    hash (Object o) = H.foldl' hashWithSalt 0 o
     hash (Array a)  = V.foldl' hashWithSalt 1 a
     hash (String s) = 2 `hashWithSalt` s
     hash (Number n) = 3 `hashWithSalt` case n of I i -> hash i; D d -> hash d
 
 -- | The empty object.
 emptyObject :: Value
-emptyObject = Object M.empty
+emptyObject = Object H.empty
 
 -- | Run a 'Parser'.
 parse :: (a -> Parser b) -> a -> Result b
 -- | Create a 'Value' from a list of name\/value 'Pair's.  If duplicate
 -- keys arise, earlier keys and their associated values win.
 object :: [Pair] -> Value
-object = Object . M.fromList
+object = Object . H.fromList
 {-# INLINE object #-}