Change Object to use an opaque KeyMap interface

aeson.cabal

@@ -1,5 +1,5 @@
 name:            aeson
-version:         1.5.6.0
+version:         2.0.0.0
 license:         BSD3
 license-file:    LICENSE
 category:        Text, Web, JSON
@@ -68,6 +68,7 @@ library
     Data.Aeson.Internal
     Data.Aeson.Internal.Time
     Data.Aeson.Parser.Internal
+    Data.Aeson.KeyMap
 
   -- Deprecated modules
   exposed-modules:

benchmarks/aeson-benchmarks.cabal

@@ -76,6 +76,7 @@ library
     Data.Aeson.Internal
     Data.Aeson.Internal.Functions
     Data.Aeson.Internal.Time
+    Data.Aeson.KeyMap
     Data.Aeson.Parser
     Data.Aeson.Parser.Internal
     Data.Aeson.Parser.Time

changelog.md

@@ -1,13 +1,16 @@
 For the latest version of this document, please see [https://github.com/haskell/aeson/blob/master/changelog.md](https://github.com/haskell/aeson/blob/master/changelog.md).
 
-### 1.6.0.0
+### 2.0.0.0
 
 * Remove forced `-O2` and then unneeded `fast` flag.
   Also remove most of `INLINE` pragmas.
   In the effect, `aeson` compiles almost twice as fast.
 
   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, thanks to Callan McGill
+
 ### 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.KeyMap as KM
 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 :: KM.KeyMap Value -> Builder
+object m = case KM.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.KeyMap as KM
 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 'KM.KeyMap' while transforming the keys.
+mapTextKeyVal :: (k -> T.Text) -> (v1 -> v2)
+              -> M.Map k v1 -> KM.KeyMap v2
+mapTextKeyVal fk kv = M.foldrWithKey (\k v -> KM.insert (fk k) (kv v)) KM.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/KeyMap.hs

@@ -0,0 +1,230 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE TemplateHaskell #-}
+
+-- |
+-- An abstract interface for maps from Textual keys to values.
+
+module Data.Aeson.KeyMap (
+    -- * Map Type
+    KeyMap,
+
+    -- * Query
+    lookup,
+    size,
+    member,
+
+    -- * Construction
+    empty,
+    singleton,
+
+    -- ** Insertion
+    insert,
+
+    -- * Combine
+    difference,
+
+    -- * Lists
+    fromList,
+    fromListWith,
+    toList,
+    toAscList,
+
+    -- * HashMaps
+    fromHashMap,
+    toHashMap,
+
+    -- * Traversal
+    -- ** Map
+    mapKeyVal,
+    traverseWithKey,
+
+    -- * Folds
+    foldrWithKey,
+
+    -- * Conversions
+    keys,
+) where
+
+#if 1
+import Control.DeepSeq (NFData(..))
+import Data.Data (Data)
+import Data.Hashable (Hashable(..))
+import Data.HashMap.Strict (HashMap)
+import Data.List (sortBy)
+import Data.Ord (comparing)
+import Data.Text (Text, unpack, pack)
+import Data.Typeable (Typeable)
+import Prelude hiding (lookup)
+import Control.Arrow (first)
+import Data.Foldable hiding (toList)
+import Text.Read
+#if __GLASGOW_HASKELL__ < 710
+import Data.Monoid (Monoid(mempty, mappend))
+import Data.Traversable (Traversable(..))
+import Control.Applicative (Applicative)
+#endif
+#if __GLASGOW_HASKELL__ >= 711
+import Data.Semigroup (Semigroup((<>)))
+#endif
+
+import qualified Data.HashMap.Strict as H
+import qualified Language.Haskell.TH.Syntax as TH
+
+newtype KeyMap v = KeyMap { unKeyMap :: HashMap Text v }
+  deriving (Eq, Ord, Typeable, Data, Functor)
+
+instance Read v => Read (KeyMap v) where
+    readPrec = parens $ prec 10 $ do
+      Ident "fromList" <- lexP
+      xs <- readPrec
+      return (fromList xs)
+
+    readListPrec = readListPrecDefault
+
+instance Show v => Show (KeyMap v) where
+    showsPrec d m = showParen (d > 10) $
+      showString "fromList " . shows (toAscList m)
+
+
+#if __GLASGOW_HASKELL__ >= 711
+instance Semigroup (KeyMap v) where
+   (KeyMap m1) <> (KeyMap m2) = KeyMap (m1 `H.union` m2)
+   {-# INLINE (<>) #-}
+#endif
+instance Monoid (KeyMap v) where
+    mempty = empty
+    {-# INLINE mempty #-}
+#if __GLASGOW_HASKELL__ >= 711
+    mappend = (<>)
+#else
+    mappend (KeyMap m1) (KeyMap m2) = KeyMap (m1 `H.union` m2)
+#endif
+    {-# INLINE mappend #-}
+
+instance Hashable v => Hashable (KeyMap v) where
+    hashWithSalt salt (KeyMap hm) = hashWithSalt salt hm
+
+instance NFData v => NFData (KeyMap v) where
+    rnf (KeyMap hm) = rnf hm
+
+instance Foldable KeyMap where
+    foldMap f (KeyMap tm) = H.foldMapWithKey (\ _k v -> f v) tm
+    {-# INLINE foldMap #-}
+    foldr f z (KeyMap tm)  = H.foldr f z tm
+    {-# INLINE foldr #-}
+    foldl f z (KeyMap tm) = H.foldl f z tm
+    {-# INLINE foldl #-}
+    foldr' f z (KeyMap tm) = H.foldr' f z tm
+    {-# INLINE foldr' #-}
+    foldl' f z (KeyMap tm) = H.foldl' f z tm
+    {-# INLINE foldl' #-}
+#if MIN_VERSION_base(4,8,0)
+    null = H.null . unKeyMap
+    {-# INLINE null #-}
+    length = size
+    {-# INLINE length #-}
+#endif
+
+instance Traversable KeyMap where
+    traverse f = traverseWithKey (const f)
+    {-# INLINABLE traverse #-}
+
+
+instance TH.Lift v => TH.Lift (KeyMap v) where
+    lift (KeyMap m) = [| KeyMap (H.fromList . map (first pack) $ m') |]
+        where
+          m' = map (first unpack) . H.toList $ m
+
+#if MIN_VERSION_template_haskell(2,17,0)
+    liftTyped = TH.unsafeCodeCoerce . TH.lift
+#elif MIN_VERSION_template_haskell(2,16,0)
+    liftTyped = TH.unsafeTExpCoerce . TH.lift
+#endif
+
+-- |
+-- Construct an empty map.
+empty :: KeyMap v
+empty = KeyMap H.empty
+
+-- |
+-- Return the number of key-value mappings in this map.
+size :: KeyMap v -> Int
+size = H.size . unKeyMap
+
+-- |
+-- Construct a map with a single element.
+singleton :: Text -> v -> KeyMap v
+singleton k v = KeyMap (H.singleton k v)
+
+member :: Text -> KeyMap a -> Bool
+member t (KeyMap m) = H.member t m
+
+-- | Return the value to which the specified key is mapped,
+-- or Nothing if this map contains no mapping for the key.
+lookup :: Text -> KeyMap v -> Maybe v
+lookup t tm = H.lookup t (unKeyMap tm)
+
+-- | Associate the specified value with the specified key
+-- in this map. If this map previously contained a mapping
+-- for the key, the old value is replaced.
+insert :: Text -> v -> KeyMap v -> KeyMap v
+insert k v tm = KeyMap (H.insert k v (unKeyMap tm))
+
+-- | Reduce this map by applying a binary operator to all
+-- elements, using the given starting value (typically the
+-- right-identity of the operator).
+foldrWithKey :: (Text -> v -> a -> a) -> a -> KeyMap v -> a
+foldrWithKey f a = H.foldrWithKey f a . unKeyMap
+
+-- | Perform an Applicative action for each key-value pair
+-- in a 'KeyMap' and produce a 'KeyMap' of all the results.
+traverseWithKey :: Applicative f => (Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2)
+traverseWithKey f = fmap KeyMap . H.traverseWithKey f  . unKeyMap
+
+-- | Construct a map from a list of elements. Uses the
+-- provided function, f, to merge duplicate entries with
+-- (f newVal oldVal).
+fromListWith :: (v -> v -> v) ->  [(Text, v)] -> KeyMap v
+fromListWith op = KeyMap . H.fromListWith op
+
+-- |  Construct a map with the supplied mappings. If the
+-- list contains duplicate mappings, the later mappings take
+-- precedence.
+fromList :: [(Text, v)] -> KeyMap v
+fromList = KeyMap . H.fromList
+
+-- | Return a list of this map's elements.
+toList :: KeyMap v -> [(Text, v)]
+toList = H.toList . unKeyMap
+
+-- | Return a list of this map's elements in ascending order
+-- based of the textual key.
+toAscList :: KeyMap v -> [(Text, v)]
+toAscList = sortBy (comparing fst) . toList
+
+-- | Difference of two maps. Return elements of the first
+-- map not existing in the second.
+difference :: KeyMap v -> KeyMap v' -> KeyMap v
+difference tm1 tm2 = KeyMap (H.difference (unKeyMap tm1) (unKeyMap tm2))
+
+-- | Return a list of this map's keys.
+keys :: KeyMap v -> [Text]
+keys = H.keys . unKeyMap
+
+-- | Convert a 'KeyMap' to a 'HashMap'.
+toHashMap :: KeyMap v -> HashMap Text v
+toHashMap = unKeyMap
+
+-- | Convert a 'HashMap' to a 'KeyMap'.
+fromHashMap :: HashMap Text v -> KeyMap v
+fromHashMap = KeyMap
+
+-- | Transform the keys and values of a 'KeyMap'.
+mapKeyVal :: (Text -> Text) -> (v1 -> v2)
+          -> KeyMap v1 -> KeyMap v2
+mapKeyVal fk kv = foldrWithKey (\k v -> insert (fk k) (kv v)) empty
+{-# INLINE mapKeyVal #-}
+
+#endif