WIP: TextMap

Author: Boarders

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

@@ -11,22 +11,31 @@
 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 'H.HashMap' 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)
           -> H.HashMap k1 v1 -> H.HashMap k2 v2

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)
@@ -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

src/Data/Aeson/TextMap.hs

@@ -1,11 +1,26 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE TemplateHaskell #-}
 module Data.Aeson.TextMap (
     TextMap,
+    difference,
     empty,
+    foldrWithKey,
+    fromHashMap,
     fromList,
+    fromListWith,
+    insert,
+    keys,
+    lookup,
+    mapKeyVal,
+    singleton,
+    size,
     toList,
     toAscList,
+    toHashMap,
+    traverseWithKey
 ) where
 
 #if 1
@@ -15,41 +30,73 @@ import Data.Hashable (Hashable(..))
 import Data.HashMap.Strict (HashMap)
 import Data.List (sortBy)
 import Data.Ord (comparing)
-import Data.Text (Text)
+import Data.Text (Text, unpack)
 import Data.Typeable (Typeable)
+import Prelude hiding (lookup)
+import Data.Bifunctor (first)
+
 
 import qualified Data.HashMap.Strict as H
 import qualified Language.Haskell.TH.Syntax as TH
 
 newtype TextMap v = TextMap { unTextMap :: HashMap Text v }
   deriving (Eq, Ord, Typeable, Data)
+  deriving newtype (Read, Show, Functor, Hashable, NFData)
 
-instance Read v => Read (TextMap v)
-    -- TODO
+instance TH.Lift v => TH.Lift (TextMap v) where
+  lift (TextMap m) = [| TextMap (H.fromList . map (first pack) $ m') |]
+      where m' = map (first unpack) . H.toList $ m
 
-instance Show v => Show (TextMap v) where
-    -- TODO
+empty :: TextMap v
+empty = TextMap H.empty
 
-instance TH.Lift v => TH.Lift (TextMap v) where
-    lift = undefined 
-    -- TODO
+size :: TextMap v -> Int
+size = H.size . unTextMap
 
-instance NFData v => NFData (TextMap v) where
-    rnf = rnf . unTextMap
+keys :: TextMap v -> [Text]
+keys = H.keys . unTextMap
 
-instance Hashable v => Hashable (TextMap v) where
-    hashWithSalt = error "TODO"
+singleton :: Text -> v -> TextMap v
+singleton k v = TextMap (H.singleton k v)
 
-empty :: TextMap v
-empty = TextMap H.empty
+insert :: Text -> v -> TextMap v -> TextMap v
+insert k v tm = TextMap (H.insert k v (unTextMap tm))
 
 fromList :: [(Text, v)] -> TextMap v
 fromList = TextMap . H.fromList
 
+fromListWith :: (v -> v -> v) ->  [(Text, v)] -> TextMap v
+fromListWith op = TextMap . H.fromListWith op
+
+traverseWithKey :: Applicative f => (Text -> v1 -> f v2) -> TextMap v1 -> f (TextMap v2)
+traverseWithKey f = fmap TextMap . H.traverseWithKey f  . unTextMap
+
+foldrWithKey :: (Text -> v -> a -> a) -> a -> TextMap v -> a
+foldrWithKey f a = H.foldrWithKey f a . unTextMap
+
+difference :: TextMap v -> TextMap v' -> TextMap v
+difference tm1 tm2 = TextMap (H.difference (unTextMap tm1) (unTextMap tm2))
+
 toList :: TextMap v -> [(Text, v)]
 toList = H.toList . unTextMap
 
 toAscList :: TextMap v -> [(Text, v)]
 toAscList = sortBy (comparing fst) . toList
 
+lookup :: Text -> TextMap v -> Maybe v
+lookup t tm = H.lookup t (unTextMap tm)
+
+toHashMap :: TextMap v -> HashMap Text v
+toHashMap = unTextMap
+
+fromHashMap :: HashMap Text v -> TextMap v
+fromHashMap = TextMap
+
+
+-- | Transform the keys and values of a 'TextMap'.
+mapKeyVal :: (Text -> Text) -> (v1 -> v2)
+          -> TextMap v1 -> TextMap v2
+mapKeyVal fk kv = foldrWithKey (\k v -> insert (fk k) (kv v)) empty
+{-# INLINE mapKeyVal #-}
+
 #endif