Change Object to use an opaque TextMap interface

Co-authored-by: Callan McGill <[email protected]>

Author: phadej

aeson.cabal

@@ -68,6 +68,7 @@ library
     Data.Aeson.Internal
     Data.Aeson.Internal.Time
     Data.Aeson.Parser.Internal
+    Data.Aeson.TextMap
 
   -- Deprecated modules
   exposed-modules:

benchmarks/aeson-benchmarks.cabal

@@ -83,6 +83,7 @@ library
     Data.Aeson.Parser.UnescapeFFI
     Data.Aeson.Parser.UnescapePure
     Data.Aeson.Text
+    Data.Aeson.TextMap
     Data.Aeson.TH
     Data.Aeson.Types
     Data.Aeson.Types.Class

changelog.md

@@ -8,6 +8,9 @@ For the latest version of this document, please see [https://github.com/haskell/
 
   To get `fast` compilation effect cabal-install users may specify `optimization: False`.
 
+* Make map type used by Object abstract so the underlying implementation can
+  be modified.
+
 ### 1.5.6.0
 * Make `Show Value` instance print object keys in lexicographic order.
 

src/Data/Aeson/Encoding/Builder.hs

@@ -42,6 +42,7 @@ import Prelude.Compat
 
 import Data.Aeson.Internal.Time
 import Data.Aeson.Types.Internal (Value (..))
+import qualified Data.Aeson.TextMap as TM
 import Data.ByteString.Builder as B
 import Data.ByteString.Builder.Prim as BP
 import Data.ByteString.Builder.Scientific (scientificBuilder)
@@ -54,7 +55,6 @@ import Data.Time.Calendar.Month.Compat (Month, toYearMonth)
 import Data.Time.Calendar.Quarter.Compat (Quarter, toYearQuarter, QuarterOfYear (..))
 import Data.Time.LocalTime
 import Data.Word (Word8)
-import qualified Data.HashMap.Strict as HMS
 import qualified Data.Text as T
 import qualified Data.Vector as V
 
@@ -90,8 +90,8 @@ array v
     withComma a z = B.char8 ',' <> encodeToBuilder a <> z
 
 -- Encode a JSON object.
-object :: HMS.HashMap T.Text Value -> Builder
-object m = case HMS.toList m of
+object :: TM.TextMap Value -> Builder
+object m = case TM.toList m of
     (x:xs) -> B.char8 '{' <> one x <> foldr withComma (B.char8 '}') xs
     _      -> emptyObject_
   where

src/Data/Aeson/Internal/Functions.hs

@@ -9,23 +9,24 @@
 -- Portability: portable
 
 module Data.Aeson.Internal.Functions
-    (
-      mapHashKeyVal
+    ( mapTextKeyVal
     , mapKeyVal
     , mapKey
     ) where
 
 import Prelude.Compat
 
 import Data.Hashable (Hashable)
+import qualified Data.Aeson.TextMap as TM
 import qualified Data.HashMap.Strict as H
 import qualified Data.Map as M
+import qualified Data.Text as T
 
--- | 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 'M.Map' into a 'TM.TextMap' while transforming the keys.
+mapTextKeyVal :: (k -> T.Text) -> (v1 -> v2)
+              -> M.Map k v1 -> TM.TextMap v2
+mapTextKeyVal fk kv = M.foldrWithKey (\k v -> TM.insert (fk k) (kv v)) TM.empty
+{-# INLINE mapTextKeyVal #-}
 
 -- | Transform the keys and values of a 'H.HashMap'.
 mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
@@ -37,3 +38,4 @@ mapKeyVal fk kv = H.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
 mapKey :: (Eq k2, Hashable k2) => (k1 -> k2) -> H.HashMap k1 v -> H.HashMap k2 v
 mapKey fk = mapKeyVal fk id
 {-# INLINE mapKey #-}
+

src/Data/Aeson/Parser/Internal.hs

@@ -52,6 +52,7 @@ import Prelude.Compat
 import Control.Applicative ((<|>))
 import Control.Monad (void, when)
 import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))
+import qualified Data.Aeson.TextMap as TM
 import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)
 import Data.Function (fix)
 import Data.Functor.Compat (($>))
@@ -68,7 +69,6 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy as BSL
 import qualified Data.ByteString.Lazy.Char8 as C
 import qualified Data.ByteString.Builder as B
-import qualified Data.HashMap.Strict as H
 import qualified Data.Scientific as Sci
 import Data.Aeson.Parser.Unescape (unescapeText)
 
@@ -146,16 +146,18 @@ object_' mkObject val' = {-# SCC "object_'" #-} do
 {-# INLINE object_' #-}
 
 objectValues :: ([(Text, Value)] -> Either String Object)
-             -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)
+             -> Parser Text -> Parser Value -> Parser (TM.TextMap Value)
 objectValues mkObject str val = do
   skipSpace
   w <- A.peekWord8'
   if w == CLOSE_CURLY
-    then A.anyWord8 >> return H.empty
+    then A.anyWord8 >> return TM.empty
     else loop []
  where
-  -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'
-  -- and it's much faster because it's doing in place update to the 'HashMap'!
+  -- Why use acc pattern here, you may ask? because then the underlying 'TM.fromList'
+  -- implementation can make use of mutation when constructing a map. For example,
+  -- 'HashMap` uses 'unsafeInsert' and it's much faster because it's doing in place
+  -- update to the 'HashMap'!
   loop acc = do
     k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")
     v <- (val A.<?> "object value") <* skipSpace
@@ -196,7 +198,7 @@ arrayValues val = do
 
 -- | Parse any JSON value. Synonym of 'json'.
 value :: Parser Value
-value = jsonWith (pure . H.fromList)
+value = jsonWith (pure . TM.fromList)
 
 -- | Parse any JSON value.
 --
@@ -206,7 +208,7 @@ value = jsonWith (pure . H.fromList)
 --
 -- ==== __Examples__
 --
--- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.
+-- 'json' keeps only the first occurence of each key, using 'Data.Aeson.TextMap.fromList'.
 --
 -- @
 -- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')
@@ -249,7 +251,7 @@ jsonWith mkObject = fix $ \value_ -> do
 
 -- | Variant of 'json' which keeps only the last occurence of every key.
 jsonLast :: Parser Value
-jsonLast = jsonWith (Right . H.fromListWith (const id))
+jsonLast = jsonWith (Right . TM.fromListWith (const id))
 
 -- | Variant of 'json' wrapping all object mappings in 'Array' to preserve
 -- key-value pairs with the same keys.
@@ -267,19 +269,20 @@ jsonNoDup = jsonWith parseListNoDup
 -- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])]
 fromListAccum :: [(Text, Value)] -> Object
 fromListAccum =
-  fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)
+  fmap (Array . Vector.fromList . ($ [])) . TM.fromListWith (.) . (fmap . fmap) (:)
 
 -- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.
 parseListNoDup :: [(Text, Value)] -> Either String Object
 parseListNoDup =
-  H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just
+  TM.traverseWithKey unwrap . TM.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just
   where
+
     unwrap k Nothing = Left $ "found duplicate key: " ++ show k
     unwrap _ (Just v) = Right v
 
 -- | Strict version of 'value'. Synonym of 'json''.
 value' :: Parser Value
-value' = jsonWith' (pure . H.fromList)
+value' = jsonWith' (pure . TM.fromList)
 
 -- | Strict version of 'jsonWith'.
 jsonWith' :: ([(Text, Value)] -> Either String Object) -> Parser Value
@@ -304,7 +307,7 @@ jsonWith' mkObject = fix $ \value_ -> do
 
 -- | Variant of 'json'' which keeps only the last occurence of every key.
 jsonLast' :: Parser Value
-jsonLast' = jsonWith' (pure . H.fromListWith (const id))
+jsonLast' = jsonWith' (pure . TM.fromListWith (const id))
 
 -- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve
 -- key-value pairs with the same keys.

src/Data/Aeson/TH.hs

@@ -128,6 +128,7 @@ import Data.Aeson.Types (Options(..), Parser, SumEncoding(..), Value(..), defaul
 import Data.Aeson.Types.Internal ((<?>), JSONPathElement(Key))
 import Data.Aeson.Types.FromJSON (parseOptionalFieldWith)
 import Data.Aeson.Types.ToJSON (fromPairs, pair)
+import qualified Data.Aeson.TextMap as TM
 import Control.Monad (liftM2, unless, when)
 import Data.Foldable (foldr')
 #if MIN_VERSION_template_haskell(2,8,0) && !MIN_VERSION_template_haskell(2,10,0)
@@ -147,7 +148,7 @@ import Language.Haskell.TH.Syntax (mkNameG_tc)
 import Text.Printf (printf)
 import qualified Data.Aeson.Encoding.Internal as E
 import qualified Data.Foldable as F (all)
-import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)
+--import qualified Data.HashMap.Strict as H (difference, fromList, keys, toList)
 import qualified Data.List.NonEmpty as NE (length, reverse)
 import qualified Data.Map as M (fromList, keys, lookup , singleton, size)
 #if !MIN_VERSION_base(4,16,0)
@@ -849,7 +850,7 @@ consFromJSON jc tName opts instTys cons = do
     parseObjectWithSingleField tvMap obj = do
       conKey <- newName "conKey"
       conVal <- newName "conVal"
-      caseE ([e|H.toList|] `appE` varE obj)
+      caseE ([e|TM.toList|] `appE` varE obj)
             [ match (listP [tupP [varP conKey, varP conVal]])
                     (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField)
                     []
@@ -947,11 +948,11 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =
     where
       tagFieldNameAppender =
           if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id
-      knownFields = appE [|H.fromList|] $ listE $
+      knownFields = appE [|TM.fromList|] $ listE $
           map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $
               tagFieldNameAppender $ map (fieldLabel opts) fields
       checkUnknownRecords =
-          caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)
+          caseE (appE [|TM.keys|] $ infixApp (varE obj) [|TM.difference|] knownFields)
               [ match (listP []) (normalB [|return ()|]) []
               , newName "unknownFields" >>=
                   \unknownFields -> match (varP unknownFields)
@@ -1149,7 +1150,7 @@ instance INCOHERENT_ LookupField (Semigroup.Option a) where
 lookupFieldWith :: (Value -> Parser a) -> String -> String
                 -> Object -> T.Text -> Parser a
 lookupFieldWith pj tName rec obj key =
-    case H.lookup key obj of
+    case TM.lookup key obj of
       Nothing -> unknownFieldFail tName rec (T.unpack key)
       Just v  -> pj v <?> Key key
 

src/Data/Aeson/Text.hs

@@ -26,11 +26,11 @@ import Prelude.Compat
 
 import Data.Aeson.Types (Value(..), ToJSON(..))
 import Data.Aeson.Encoding (encodingToLazyByteString)
+import qualified Data.Aeson.TextMap as TM
 import Data.Scientific (FPFormat(..), Scientific, base10Exponent)
 import Data.Text.Lazy.Builder
 import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
 import Numeric (showHex)
-import qualified Data.HashMap.Strict as H
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as LT
 import qualified Data.Text.Lazy.Encoding as LT
@@ -66,7 +66,7 @@ encodeToTextBuilder =
                       V.foldr f (singleton ']') (V.unsafeTail v)
       where f a z = singleton ',' <> go a <> z
     go (Object m) = {-# SCC "go/Object" #-}
-        case H.toList m of
+        case TM.toList m of
           (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs
           _      -> "{}"
       where f a z     = singleton ',' <> one a <> z