From 2719321095df3561ac2d26015dc9f7d870912ac3 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 15 Sep 2021 15:24:35 +0300 Subject: [PATCH] Introduce Data.Aeson.Key --- aeson.cabal | 1 + benchmarks/aeson-benchmarks.cabal | 1 + src/Data/Aeson.hs | 1 + src/Data/Aeson/Encoding/Builder.hs | 9 ++- src/Data/Aeson/Encoding/Internal.hs | 15 +++-- src/Data/Aeson/Internal/Functions.hs | 4 +- src/Data/Aeson/Key.hs | 89 ++++++++++++++++++++++++++++ src/Data/Aeson/KeyMap.hs | 65 ++++++++++---------- src/Data/Aeson/Parser/Internal.hs | 31 ++++++---- src/Data/Aeson/TH.hs | 45 +++++++------- src/Data/Aeson/Text.hs | 3 +- src/Data/Aeson/Types.hs | 1 + src/Data/Aeson/Types/FromJSON.hs | 69 +++++++++++---------- src/Data/Aeson/Types/Internal.hs | 12 ++-- src/Data/Aeson/Types/ToJSON.hs | 57 ++++++++++-------- tests/Encoders.hs | 8 +-- tests/Instances.hs | 4 ++ tests/PropUtils.hs | 3 +- 18 files changed, 275 insertions(+), 143 deletions(-) create mode 100644 src/Data/Aeson/Key.hs diff --git a/aeson.cabal b/aeson.cabal index ac27fd553..5ead9e197 100644 --- a/aeson.cabal +++ b/aeson.cabal @@ -68,6 +68,7 @@ library Data.Aeson.Internal Data.Aeson.Internal.Time Data.Aeson.Parser.Internal + Data.Aeson.Key Data.Aeson.KeyMap -- Deprecated modules diff --git a/benchmarks/aeson-benchmarks.cabal b/benchmarks/aeson-benchmarks.cabal index dcb053aa1..cba908786 100644 --- a/benchmarks/aeson-benchmarks.cabal +++ b/benchmarks/aeson-benchmarks.cabal @@ -81,6 +81,7 @@ library Data.Aeson.Internal Data.Aeson.Internal.Functions Data.Aeson.Internal.Time + Data.Aeson.Key Data.Aeson.KeyMap Data.Aeson.Parser Data.Aeson.Parser.Internal diff --git a/src/Data/Aeson.hs b/src/Data/Aeson.hs index 77880b73d..3f6461d22 100644 --- a/src/Data/Aeson.hs +++ b/src/Data/Aeson.hs @@ -55,6 +55,7 @@ module Data.Aeson , fromEncoding , Array , Object + , Key -- * Convenience types , DotNetTime(..) -- * Type conversion diff --git a/src/Data/Aeson/Encoding/Builder.hs b/src/Data/Aeson/Encoding/Builder.hs index 8e1c6e6a3..fb3696d1e 100644 --- a/src/Data/Aeson/Encoding/Builder.hs +++ b/src/Data/Aeson/Encoding/Builder.hs @@ -41,7 +41,8 @@ module Data.Aeson.Encoding.Builder import Prelude.Compat import Data.Aeson.Internal.Time -import Data.Aeson.Types.Internal (Value (..)) +import Data.Aeson.Types.Internal (Value (..), Key) +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.ByteString.Builder as B import Data.ByteString.Builder.Prim as BP @@ -96,7 +97,11 @@ object m = case KM.toList m of _ -> emptyObject_ where withComma a z = B.char8 ',' <> one a <> z - one (k,v) = text k <> B.char8 ':' <> encodeToBuilder v + one (k,v) = key k <> B.char8 ':' <> encodeToBuilder v + +-- | Encode a JSON key. +key :: Key -> Builder +key = text . Key.toText -- | Encode a JSON string. text :: T.Text -> Builder diff --git a/src/Data/Aeson/Encoding/Internal.hs b/src/Data/Aeson/Encoding/Internal.hs index 3f38db315..181ae66fd 100644 --- a/src/Data/Aeson/Encoding/Internal.hs +++ b/src/Data/Aeson/Encoding/Internal.hs @@ -26,6 +26,7 @@ module Data.Aeson.Encoding.Internal , wrapArray , null_ , bool + , key , text , lazyText , string @@ -61,8 +62,9 @@ module Data.Aeson.Encoding.Internal import Prelude.Compat -import Data.Aeson.Types.Internal (Value) +import Data.Aeson.Types.Internal (Value, Key) import Data.ByteString.Builder (Builder, char7, toLazyByteString) +import qualified Data.Aeson.Key as Key import Data.Int import Data.Scientific (Scientific) import Data.Text (Text) @@ -127,15 +129,15 @@ data Series = Empty | Value (Encoding' Series) deriving (Typeable) -pair :: Text -> Encoding -> Series -pair name val = pair' (text name) val +pair :: Key -> Encoding -> Series +pair name val = pair' (key name) val {-# INLINE pair #-} pairStr :: String -> Encoding -> Series pairStr name val = pair' (string name) val {-# INLINE pairStr #-} -pair' :: Encoding' Text -> Encoding -> Series +pair' :: Encoding' Key -> Encoding -> Series pair' name val = Value $ retagEncoding $ retagEncoding name >< colon >< val instance Semigroup Series where @@ -184,7 +186,7 @@ list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket -- | Encode as JSON object dict - :: (k -> Encoding' Text) -- ^ key encoding + :: (k -> Encoding' Key) -- ^ key encoding -> (v -> Encoding) -- ^ value encoding -> (forall a. (k -> v -> a -> a) -> a -> m -> a) -- ^ @foldrWithKey@ - indexed fold -> m -- ^ container @@ -226,6 +228,9 @@ tuple :: Encoding' InArray -> Encoding tuple b = retagEncoding $ openBracket >< b >< closeBracket {-# INLINE tuple #-} +key :: Key -> Encoding' a +key = text . Key.toText + text :: Text -> Encoding' a text = Encoding . EB.text diff --git a/src/Data/Aeson/Internal/Functions.hs b/src/Data/Aeson/Internal/Functions.hs index 77bb6a86f..65134f283 100644 --- a/src/Data/Aeson/Internal/Functions.hs +++ b/src/Data/Aeson/Internal/Functions.hs @@ -17,13 +17,13 @@ module Data.Aeson.Internal.Functions import Prelude.Compat import Data.Hashable (Hashable) +import Data.Aeson.Key (Key) 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 'KM.KeyMap' while transforming the keys. -mapTextKeyVal :: (k -> T.Text) -> (v1 -> v2) +mapTextKeyVal :: (k -> Key) -> (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 #-} diff --git a/src/Data/Aeson/Key.hs b/src/Data/Aeson/Key.hs new file mode 100644 index 000000000..648c7e1d3 --- /dev/null +++ b/src/Data/Aeson/Key.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} + +#if __GLASGOW_HASKELL__ >= 800 +-- a) THQ works on cross-compilers and unregisterised GHCs +-- b) may make compilation faster as no dynamic loading is ever needed (not sure about this) +-- c) removes one hindrance to have code inferred as SafeHaskell safe +{-# LANGUAGE TemplateHaskellQuotes #-} +#else +{-# LANGUAGE TemplateHaskell #-} +#endif + +module Data.Aeson.Key ( + Key, + fromString, + toString, + toText, + fromText, +) where + +import Prelude (Eq, Ord, (.), Show (..), String) + +import Control.Applicative ((<$>)) +import Control.DeepSeq (NFData(..)) +import Data.Data (Data) +import Data.Hashable (Hashable(..)) +import Data.Monoid (Monoid(mempty, mappend)) +import Data.Semigroup (Semigroup((<>))) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Text.Read (Read (..)) + +import qualified Data.String +import qualified Data.Text as T +import qualified Language.Haskell.TH.Syntax as TH + +newtype Key = Key { unKey :: Text } + deriving (Eq, Ord, Typeable, Data) + +fromString :: String -> Key +fromString = Key . T.pack + +toString :: Key -> String +toString (Key k) = T.unpack k + +fromText :: Text -> Key +fromText = Key + +toText :: Key -> Text +toText = unKey + +------------------------------------------------------------------------------- +-- instances +------------------------------------------------------------------------------- + +instance Read Key where + readPrec = fromString <$> readPrec + +instance Show Key where + showsPrec d (Key k) = showsPrec d k + +instance Data.String.IsString Key where + fromString = fromString + +instance Hashable Key where + hashWithSalt salt (Key k) = hashWithSalt salt k + +instance NFData Key where + rnf (Key k) = rnf k + +instance Semigroup Key where + Key x <> Key y = Key (x <> y) + +instance Monoid Key where + mempty = Key mempty + mappend = (<>) + +instance TH.Lift Key where +#if MIN_VERSION_text(1,2,4) + lift (Key k) = [| Key k |] +#else + lift k = [| fromString k' |] where k' = toString k +#endif + +#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 diff --git a/src/Data/Aeson/KeyMap.hs b/src/Data/Aeson/KeyMap.hs index 363af099c..14ddce5c3 100644 --- a/src/Data/Aeson/KeyMap.hs +++ b/src/Data/Aeson/KeyMap.hs @@ -86,11 +86,11 @@ import Prelude (Show, showsPrec, showParen, shows, showString) import Control.Applicative (Applicative) import Control.DeepSeq (NFData(..)) +import Data.Aeson.Key (Key) import Data.Data (Data) import Data.Hashable (Hashable(..)) import Data.Monoid (Monoid(mempty, mappend)) import Data.Semigroup (Semigroup((<>))) -import Data.Text (Text, unpack, pack) import Data.These (These (..)) import Data.Typeable (Typeable) import Text.Read (Read (..), Lexeme(..), readListPrecDefault, prec, lexP, parens) @@ -113,12 +113,11 @@ import qualified Witherable as W import Data.HashMap.Strict (HashMap) import Data.List (sortBy) import Data.Ord (comparing) -import Control.Arrow (first) import qualified Data.HashMap.Strict as H -- | A map from JSON key type 'Key' to 'v'. -newtype KeyMap v = KeyMap { unKeyMap :: HashMap Text v } +newtype KeyMap v = KeyMap { unKeyMap :: HashMap Key v } deriving (Eq, Ord, Typeable, Data, Functor) -- | Construct an empty map. @@ -134,22 +133,22 @@ size :: KeyMap v -> Int size = H.size . unKeyMap -- | Construct a map with a single element. -singleton :: Text -> v -> KeyMap v +singleton :: Key -> v -> KeyMap v singleton k v = KeyMap (H.singleton k v) -- | Is the key a member of the map? -member :: Text -> KeyMap a -> Bool +member :: Key -> 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 :: Key -> 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 :: Key -> v -> KeyMap v -> KeyMap v insert k v tm = KeyMap (H.insert k v (unKeyMap tm)) -- | Map a function over all values in the map. @@ -157,10 +156,10 @@ map :: (a -> b) -> KeyMap a -> KeyMap b map = fmap -- | Map a function over all values in the map. -mapWithKey :: (Text -> a -> b) -> KeyMap a -> KeyMap b +mapWithKey :: (Key -> a -> b) -> KeyMap a -> KeyMap b mapWithKey f (KeyMap m) = KeyMap (H.mapWithKey f m) -foldMapWithKey :: Monoid m => (Text -> a -> m) -> KeyMap a -> m +foldMapWithKey :: Monoid m => (Key -> a -> m) -> KeyMap a -> m foldMapWithKey f (KeyMap m) = H.foldMapWithKey f m foldr :: (a -> b -> b) -> b -> KeyMap a -> b @@ -178,7 +177,7 @@ foldl' f z (KeyMap m) = H.foldl' f z m -- | 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 :: (Key -> v -> a -> a) -> a -> KeyMap v -> a foldrWithKey f a = H.foldrWithKey f a . unKeyMap -- | Perform an Applicative action for each key-value pair @@ -188,30 +187,30 @@ traverse f = fmap KeyMap . T.traverse f . 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 :: Applicative f => (Key -> 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 :: (v -> v -> v) -> [(Key, 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 :: [(Key, v)] -> KeyMap v fromList = KeyMap . H.fromList -- | Return a list of this map's elements. -- -- The order is not stable. Use 'toAscList' for stable ordering. -toList :: KeyMap v -> [(Text, v)] +toList :: KeyMap v -> [(Key, 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 :: KeyMap v -> [(Key, v)] toAscList = sortBy (comparing fst) . toList -- | Difference of two maps. Return elements of the first @@ -229,7 +228,7 @@ unionWith :: (v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v unionWith f (KeyMap x) (KeyMap y) = KeyMap (H.unionWith f x y) -- | The union with a combining function. -unionWithKey :: (Text -> v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v +unionWithKey :: (Key -> v -> v -> v) -> KeyMap v -> KeyMap v -> KeyMap v unionWithKey f (KeyMap x) (KeyMap y) = KeyMap (H.unionWithKey f x y) -- | The (left-biased) intersection of two maps (based on keys). @@ -241,23 +240,23 @@ intersectionWith :: (a -> b -> c) -> KeyMap a -> KeyMap b -> KeyMap c intersectionWith f (KeyMap x) (KeyMap y) = KeyMap (H.intersectionWith f x y) -- | The intersection with a combining function. -intersectionWithKey :: (Text -> a -> b -> c) -> KeyMap a -> KeyMap b -> KeyMap c +intersectionWithKey :: (Key -> a -> b -> c) -> KeyMap a -> KeyMap b -> KeyMap c intersectionWithKey f (KeyMap x) (KeyMap y) = KeyMap (H.intersectionWithKey f x y) -- | Return a list of this map's keys. -keys :: KeyMap v -> [Text] +keys :: KeyMap v -> [Key] keys = H.keys . unKeyMap -- | Convert a 'KeyMap' to a 'HashMap'. -toHashMap :: KeyMap v -> HashMap Text v +toHashMap :: KeyMap v -> HashMap Key v toHashMap = unKeyMap -- | Convert a 'HashMap' to a 'KeyMap'. -fromHashMap :: HashMap Text v -> KeyMap v +fromHashMap :: HashMap Key v -> KeyMap v fromHashMap = KeyMap -- | Transform the keys and values of a 'KeyMap'. -mapKeyVal :: (Text -> Text) -> (v1 -> v2) +mapKeyVal :: (Key -> Key) -> (v1 -> v2) -> KeyMap v1 -> KeyMap v2 mapKeyVal fk kv = foldrWithKey (\k v -> insert (fk k) (kv v)) empty {-# INLINE mapKeyVal #-} @@ -267,7 +266,7 @@ filter :: (v -> Bool) -> KeyMap v -> KeyMap v filter f (KeyMap m) = KeyMap (H.filter f m) -- | Filter all keys/values that satisfy some predicate. -filterWithKey :: (Text -> v -> Bool) -> KeyMap v -> KeyMap v +filterWithKey :: (Key -> v -> Bool) -> KeyMap v -> KeyMap v filterWithKey f (KeyMap m) = KeyMap (H.filterWithKey f m) -- | Map values and collect the Just results. @@ -275,7 +274,7 @@ mapMaybe :: (a -> Maybe b) -> KeyMap a -> KeyMap b mapMaybe f (KeyMap m) = KeyMap (H.mapMaybe f m) -- | Map values and collect the Just results. -mapMaybeWithKey :: (Text -> v -> Maybe u) -> KeyMap v -> KeyMap u +mapMaybeWithKey :: (Key -> v -> Maybe u) -> KeyMap v -> KeyMap u mapMaybeWithKey f (KeyMap m) = KeyMap (H.mapMaybeWithKey f m) #endif @@ -289,7 +288,7 @@ alignWith :: (These a b -> c) -> KeyMap a -> KeyMap b -> KeyMap c alignWith f (KeyMap x) (KeyMap y) = KeyMap (SA.alignWith f x y) -- | Generalized union with combining function. -alignWithKey :: (Text -> These a b -> c) -> KeyMap a -> KeyMap b -> KeyMap c +alignWithKey :: (Key -> These a b -> c) -> KeyMap a -> KeyMap b -> KeyMap c alignWithKey f (KeyMap x) (KeyMap y) = KeyMap (SAI.ialignWith f x y) ------------------------------------------------------------------------------- @@ -341,9 +340,7 @@ instance Monoid (KeyMap v) where ------------------------------------------------------------------------------- instance TH.Lift v => TH.Lift (KeyMap v) where - lift m = [| fromList (L.map (first pack) m') |] - where - m' = L.map (first unpack) . toList $ m + lift m = [| fromList m' |] where m' = toList m #if MIN_VERSION_template_haskell(2,17,0) liftTyped = TH.unsafeCodeCoerce . TH.lift @@ -369,13 +366,13 @@ instance NFData v => NFData (KeyMap v) where -- indexed-traversable ------------------------------------------------------------------------------- -instance WI.FunctorWithIndex Text KeyMap where +instance WI.FunctorWithIndex Key KeyMap where imap = mapWithKey -instance WI.FoldableWithIndex Text KeyMap where +instance WI.FoldableWithIndex Key KeyMap where ifoldr = foldrWithKey -instance WI.TraversableWithIndex Text KeyMap where +instance WI.TraversableWithIndex Key KeyMap where itraverse = traverseWithKey ------------------------------------------------------------------------------- @@ -385,13 +382,13 @@ instance WI.TraversableWithIndex Text KeyMap where instance SA.Zip KeyMap where zipWith = intersectionWith -instance SAI.ZipWithIndex Text KeyMap where +instance SAI.ZipWithIndex Key KeyMap where izipWith = intersectionWithKey instance SA.Semialign KeyMap where alignWith = alignWith -instance SAI.SemialignWithIndex Text KeyMap where +instance SAI.SemialignWithIndex Key KeyMap where ialignWith = alignWithKey instance SA.Align KeyMap where @@ -408,9 +405,9 @@ instance W.Filterable KeyMap where instance W.Witherable KeyMap where -instance W.FilterableWithIndex Text KeyMap where +instance W.FilterableWithIndex Key KeyMap where ifilter = filterWithKey imapMaybe = mapMaybeWithKey -instance W.WitherableWithIndex Text KeyMap where +instance W.WitherableWithIndex Key KeyMap where #endif diff --git a/src/Data/Aeson/Parser/Internal.hs b/src/Data/Aeson/Parser/Internal.hs index 533e5bb47..5c75c3e52 100644 --- a/src/Data/Aeson/Parser/Internal.hs +++ b/src/Data/Aeson/Parser/Internal.hs @@ -51,8 +51,9 @@ import Prelude.Compat import Control.Applicative ((<|>)) import Control.Monad (void, when) -import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..)) +import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..), Key) import qualified Data.Aeson.KeyMap as KM +import qualified Data.Aeson.Key as Key import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string) import Data.Function (fix) import Data.Functor.Compat (($>)) @@ -131,22 +132,22 @@ json' = value' -- toplevel Value parser to be called recursively, to keep the parameter -- mkObject outside of the recursive loop for proper inlining. -object_ :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value -object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject jstring val +object_ :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value +object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject key val {-# INLINE object_ #-} -object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value +object_' :: ([(Key, Value)] -> Either String Object) -> Parser Value -> Parser Value object_' mkObject val' = {-# SCC "object_'" #-} do - !vals <- objectValues mkObject jstring' val' + !vals <- objectValues mkObject key' val' return (Object vals) where - jstring' = do - !s <- jstring + key' = do + !s <- key return s {-# INLINE object_' #-} -objectValues :: ([(Text, Value)] -> Either String Object) - -> Parser Text -> Parser Value -> Parser (KM.KeyMap Value) +objectValues :: ([(Key, Value)] -> Either String Object) + -> Parser Key -> Parser Value -> Parser (KM.KeyMap Value) objectValues mkObject str val = do skipSpace w <- A.peekWord8' @@ -233,7 +234,7 @@ value = jsonWith (pure . KM.fromList) -- @ -- 'jsonNoDup' = 'jsonWith' 'parseListNoDup' -- @ -jsonWith :: ([(Text, Value)] -> Either String Object) -> Parser Value +jsonWith :: ([(Key, Value)] -> Either String Object) -> Parser Value jsonWith mkObject = fix $ \value_ -> do skipSpace w <- A.peekWord8' @@ -267,12 +268,12 @@ jsonNoDup = jsonWith parseListNoDup -- -- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)] -- fromList [("apple",Array [Bool False,Bool True]),("orange",Array [Bool False])] -fromListAccum :: [(Text, Value)] -> Object +fromListAccum :: [(Key, Value)] -> Object fromListAccum = fmap (Array . Vector.fromList . ($ [])) . KM.fromListWith (.) . (fmap . fmap) (:) -- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys. -parseListNoDup :: [(Text, Value)] -> Either String Object +parseListNoDup :: [(Key, Value)] -> Either String Object parseListNoDup = KM.traverseWithKey unwrap . KM.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just where @@ -285,7 +286,7 @@ value' :: Parser Value value' = jsonWith' (pure . KM.fromList) -- | Strict version of 'jsonWith'. -jsonWith' :: ([(Text, Value)] -> Either String Object) -> Parser Value +jsonWith' :: ([(Key, Value)] -> Either String Object) -> Parser Value jsonWith' mkObject = fix $ \value_ -> do skipSpace w <- A.peekWord8' @@ -322,6 +323,10 @@ jsonNoDup' = jsonWith' parseListNoDup jstring :: Parser Text jstring = A.word8 DOUBLE_QUOTE *> jstring_ +-- | Parse a JSON Key +key :: Parser Key +key = Key.fromText <$> jstring + -- | Parse a string without a leading quote. jstring_ :: Parser Text {-# INLINE jstring_ #-} diff --git a/src/Data/Aeson/TH.hs b/src/Data/Aeson/TH.hs index 6dd04518e..28ffb93f0 100644 --- a/src/Data/Aeson/TH.hs +++ b/src/Data/Aeson/TH.hs @@ -128,6 +128,8 @@ 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 Data.Aeson.Key (Key) +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Control.Monad (liftM2, unless, when) import Data.Foldable (foldr') @@ -154,7 +156,7 @@ import qualified Data.Map as M (fromList, keys, lookup , singleton, size) import qualified Data.Semigroup as Semigroup (Option(..)) #endif import qualified Data.Set as Set (empty, insert, member) -import qualified Data.Text as T (Text, pack, unpack) +import qualified Data.Text as T (pack, unpack) import qualified Data.Vector as V (unsafeIndex, null, length, create, empty) import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite) @@ -583,7 +585,7 @@ fromPairsE = ([|fromPairs|] `appE`) -- -- > pairE "k" [|v|] = [|pair "k" v|] pairE :: String -> ExpQ -> ExpQ -pairE k v = [|pair k|] `appE` v +pairE k v = [|pair (Key.fromString k)|] `appE` v -------------------------------------------------------------------------------- -- FromJSON @@ -704,7 +706,7 @@ consFromJSON jc tName opts instTys cons = do else mixedMatches tvMap allNullaryMatches = - [ do txt <- newName "txt" + [ do txt <- newName "txtX" match (conP 'String [varP txt]) (guardedB $ [ liftM2 (,) (normalG $ @@ -781,12 +783,12 @@ consFromJSON jc tName opts instTys cons = do ] parseTaggedObject tvMap typFieldName valFieldName obj = do - conKey <- newName "conKey" + conKey <- newName "conKeyX" doE [ bindS (varP conKey) (infixApp (varE obj) [|(.:)|] - ([|T.pack|] `appE` stringE typFieldName)) - , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject + ([|Key.fromString|] `appE` stringE typFieldName)) + , noBindS $ parseContents tvMap conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject [|Key.fromString|] [|Key.toString|] ] parseUntaggedValue tvMap cons' conVal = @@ -815,8 +817,8 @@ consFromJSON jc tName opts instTys cons = do parse2ElemArray tvMap arr = do - conKey <- newName "conKey" - conVal <- newName "conVal" + conKey <- newName "conKeyY" + conVal <- newName "conValY" let letIx n ix = valD (varP n) (normalB ([|V.unsafeIndex|] `appE` @@ -827,12 +829,13 @@ consFromJSON jc tName opts instTys cons = do , letIx conVal 1 ] (caseE (varE conKey) - [ do txt <- newName "txt" + [ do txt <- newName "txtY" match (conP 'String [varP txt]) (normalB $ parseContents tvMap txt (Right conVal) 'conNotFoundFail2ElemArray + [|T.pack|] [|T.unpack|] ) [] , do other <- newName "other" @@ -847,11 +850,11 @@ consFromJSON jc tName opts instTys cons = do ) parseObjectWithSingleField tvMap obj = do - conKey <- newName "conKey" - conVal <- newName "conVal" + conKey <- newName "conKeyZ" + conVal <- newName "conValZ" caseE ([e|KM.toList|] `appE` varE obj) [ match (listP [tupP [varP conKey, varP conVal]]) - (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField) + (normalB $ parseContents tvMap conKey (Right conVal) 'conNotFoundFailObjectSingleField [|Key.fromString|] [|Key.toString|]) [] , do other <- newName "other" match (varP other) @@ -862,13 +865,13 @@ consFromJSON jc tName opts instTys cons = do [] ] - parseContents tvMap conKey contents errorFun = + parseContents tvMap conKey contents errorFun pack unpack= caseE (varE conKey) [ match wildP ( guardedB $ [ do g <- normalG $ infixApp (varE conKey) [|(==)|] - ([|T.pack|] `appE` + (pack `appE` conNameExp opts con) e <- checkExi tvMap con $ parseArgs jc tvMap tName opts con contents @@ -887,7 +890,7 @@ consFromJSON jc tName opts instTys cons = do . constructorName ) cons ) - `appE` ([|T.unpack|] `appE` varE conKey) + `appE` (unpack `appE` varE conKey) ) ] ) @@ -948,7 +951,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject = tagFieldNameAppender = if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id knownFields = appE [|KM.fromList|] $ listE $ - map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $ + map (\knownName -> tupE [appE [|Key.fromString|] $ litE $ stringL knownName, [|()|]]) $ tagFieldNameAppender $ map (fieldLabel opts) fields checkUnknownRecords = caseE (appE [|KM.keys|] $ infixApp (varE obj) [|KM.difference|] knownFields) @@ -966,7 +969,7 @@ parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject = `appE` litE (stringL $ show tName) `appE` litE (stringL $ constructorTagModifier opts $ nameBase conName) `appE` varE obj - `appE` ( [|T.pack|] `appE` stringE (fieldLabel opts field) + `appE` ( [|Key.fromString|] `appE` stringE (fieldLabel opts field) ) | (field, argTy) <- zip fields argTys ] @@ -976,7 +979,7 @@ getValField obj valFieldName matches = do val <- newName "val" doE [ bindS (varP val) $ infixApp (varE obj) [|(.:)|] - ([|T.pack|] `appE` + ([|Key.fromString|] `appE` litE (stringL valFieldName)) , noBindS $ caseE (varE val) matches ] @@ -1131,7 +1134,7 @@ parseTypeMismatch tName conName expected actual = class LookupField a where lookupField :: (Value -> Parser a) -> String -> String - -> Object -> T.Text -> Parser a + -> Object -> Key -> Parser a instance OVERLAPPABLE_ LookupField a where lookupField = lookupFieldWith @@ -1147,10 +1150,10 @@ instance INCOHERENT_ LookupField (Semigroup.Option a) where #endif lookupFieldWith :: (Value -> Parser a) -> String -> String - -> Object -> T.Text -> Parser a + -> Object -> Key -> Parser a lookupFieldWith pj tName rec obj key = case KM.lookup key obj of - Nothing -> unknownFieldFail tName rec (T.unpack key) + Nothing -> unknownFieldFail tName rec (Key.toString key) Just v -> pj v Key key unknownFieldFail :: String -> String -> String -> Parser fail diff --git a/src/Data/Aeson/Text.hs b/src/Data/Aeson/Text.hs index 493eb1c81..b5cede296 100644 --- a/src/Data/Aeson/Text.hs +++ b/src/Data/Aeson/Text.hs @@ -31,6 +31,7 @@ import Data.Scientific (FPFormat(..), Scientific, base10Exponent) import Data.Text.Lazy.Builder import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder) import Numeric (showHex) +import qualified Data.Aeson.Key as Key import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Encoding as LT @@ -70,7 +71,7 @@ encodeToTextBuilder = (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs _ -> "{}" where f a z = singleton ',' <> one a <> z - one (k,v) = string k <> singleton ':' <> go v + one (k,v) = string (Key.toText k) <> singleton ':' <> go v string :: T.Text -> Builder string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"' diff --git a/src/Data/Aeson/Types.hs b/src/Data/Aeson/Types.hs index 78cd363a2..f770c4647 100644 --- a/src/Data/Aeson/Types.hs +++ b/src/Data/Aeson/Types.hs @@ -14,6 +14,7 @@ module Data.Aeson.Types ( -- * Core JSON types Value(..) + , Key , Encoding , unsafeToEncoding , fromEncoding diff --git a/src/Data/Aeson/Types/FromJSON.hs b/src/Data/Aeson/Types/FromJSON.hs index f5c2aa903..de0762fec 100644 --- a/src/Data/Aeson/Types/FromJSON.hs +++ b/src/Data/Aeson/Types/FromJSON.hs @@ -122,6 +122,7 @@ import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S) import Unsafe.Coerce (unsafeCoerce) import qualified Data.Aeson.Parser.Time as Time +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific) import qualified Data.ByteString.Lazy as L @@ -224,7 +225,7 @@ parseBoundedIntegralText name t = parseScientificText t >>= parseBoundedIntegralFromScientific parseOptionalFieldWith :: (Value -> Parser (Maybe a)) - -> Object -> Text -> Parser (Maybe a) + -> Object -> Key -> Parser (Maybe a) parseOptionalFieldWith pj obj key = case KM.lookup key obj of Nothing -> pure Nothing @@ -784,7 +785,7 @@ ifromJSON = iparse parseJSON -- This accessor is appropriate if the key and value /must/ be present -- in an object for it to be valid. If the key and value are -- optional, use '.:?' instead. -(.:) :: (FromJSON a) => Object -> Text -> Parser a +(.:) :: (FromJSON a) => Object -> Key -> Parser a (.:) = explicitParseField parseJSON -- | Retrieve the value associated with the given key of an 'Object'. The @@ -794,7 +795,7 @@ ifromJSON = iparse parseJSON -- This accessor is most useful if the key and value can be absent -- from an object without affecting its validity. If the key and -- value are mandatory, use '.:' instead. -(.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) +(.:?) :: (FromJSON a) => Object -> Key -> Parser (Maybe a) (.:?) = explicitParseFieldMaybe parseJSON -- | Retrieve the value associated with the given key of an 'Object'. @@ -803,37 +804,37 @@ ifromJSON = iparse parseJSON -- -- This differs from '.:?' by attempting to parse 'Null' the same as any -- other JSON value, instead of interpreting it as 'Nothing'. -(.:!) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) +(.:!) :: (FromJSON a) => Object -> Key -> Parser (Maybe a) (.:!) = explicitParseFieldMaybe' parseJSON -- | Function variant of '.:'. -parseField :: (FromJSON a) => Object -> Text -> Parser a +parseField :: (FromJSON a) => Object -> Key -> Parser a parseField = (.:) -- | Function variant of '.:?'. -parseFieldMaybe :: (FromJSON a) => Object -> Text -> Parser (Maybe a) +parseFieldMaybe :: (FromJSON a) => Object -> Key -> Parser (Maybe a) parseFieldMaybe = (.:?) -- | Function variant of '.:!'. -parseFieldMaybe' :: (FromJSON a) => Object -> Text -> Parser (Maybe a) +parseFieldMaybe' :: (FromJSON a) => Object -> Key -> Parser (Maybe a) parseFieldMaybe' = (.:!) -- | Variant of '.:' with explicit parser function. -- -- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@ -explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a +explicitParseField :: (Value -> Parser a) -> Object -> Key -> Parser a explicitParseField p obj key = case KM.lookup key obj of Nothing -> fail $ "key " ++ show key ++ " not found" Just v -> p v Key key -- | Variant of '.:?' with explicit parser function. -explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a) +explicitParseFieldMaybe :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a) explicitParseFieldMaybe p obj key = case KM.lookup key obj of Nothing -> pure Nothing Just v -> liftParseJSON p (listParser p) v Key key -- listParser isn't used by maybe instance. -- | Variant of '.:!' with explicit parser function. -explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Text -> Parser (Maybe a) +explicitParseFieldMaybe' :: (Value -> Parser a) -> Object -> Key -> Parser (Maybe a) explicitParseFieldMaybe' p obj key = case KM.lookup key obj of Nothing -> pure Nothing Just v -> Just <$> p v Key key @@ -885,9 +886,9 @@ contextType = prependContext -- | Left "Error in $: parsing T failed, expected an object with keys "tag" and -- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"], -- | The parser returned error was: could not find key "tag" -contextTag :: Text -> [String] -> Parser a -> Parser a +contextTag :: Key -> [String] -> Parser a -> Parser a contextTag tagKey cnames = prependFailure - ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++ + ("expected Object with key \"" ++ Key.toString tagKey ++ "\"" ++ " containing one of " ++ show cnames ++ ", ") -- | Add the name of the constructor being parsed to a parser's error messages. @@ -1098,7 +1099,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) = fromMaybe (badTag tag Key tagKey) $ parseFromTaggedObject (tag :* contentsFieldName :* p) obj where - tagKey = pack tagFieldName + tagKey = Key.fromString tagFieldName badTag tag = failWith_ $ \cnames -> "expected tag field to be one of " ++ show cnames ++ ", but found tag " ++ show tag @@ -1120,7 +1121,7 @@ parseNonAllNullarySum p@(tname :* opts :* _) = withArray tname $ \arr -> case V.length arr of 2 | String tag <- V.unsafeIndex arr 0 -> maybe (badTag tag Index 0) ( Index 1) $ - parsePair (tag :* p) (V.unsafeIndex arr 1) + parsePair (Key.fromText tag :* p) (V.unsafeIndex arr 1) | otherwise -> contextType tname $ fail "tag element is not a String" Index 0 @@ -1187,7 +1188,7 @@ instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where contents <- contextCons cname tname (obj .: key) consParseJSON p' contents Key key where - key = pack contentsFieldName + key = Key.fromString contentsFieldName contentsFieldName :* p'@(cname :* tname :* _) = p {-# INLINE parseFromTaggedObject' #-} @@ -1283,7 +1284,7 @@ instance ( FieldNames f \obj -> checkUnknown obj >> recordParseJSON' p obj where knownFields :: KM.KeyMap () - knownFields = KM.fromList $ map ((,()) . pack) $ + knownFields = KM.fromList $ map ((,()) . Key.fromString) $ [tagFieldName (sumEncoding opts) | fromTaggedSum] <> (fieldLabelModifier opts <$> fieldNames (undefined :: f a) []) @@ -1315,15 +1316,15 @@ instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) => fv <- contextCons cname tname (obj .: label) M1 <$> gParseJSON opts fargs fv Key label where - label = pack $ fieldLabelModifier opts sname + label = Key.fromString $ fieldLabelModifier opts sname sname = selName (undefined :: M1 _i s _f _p) {-# INLINE recordParseJSON' #-} instance INCOHERENT_ (Selector s, FromJSON a) => RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where - recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label + recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? label where - label = fieldLabelModifier opts sname + label = Key.fromString $ fieldLabelModifier opts sname sname = selName (undefined :: M1 _i s _f _p) {-# INLINE recordParseJSON' #-} @@ -1385,7 +1386,7 @@ instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where class FromPair arity f where -- The first component of the parameter tuple is the tag to match. - parsePair :: Text :* TypeName :* Options :* FromArgs arity a + parsePair :: Key :* TypeName :* Options :* FromArgs arity a -> Value -> Maybe (Parser (f a)) @@ -1404,7 +1405,7 @@ instance ( Constructor c | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v | otherwise = Nothing where - tag' = pack $ constructorTagModifier opts cname + tag' = Key.fromString $ constructorTagModifier opts cname cname = conName (undefined :: M1 _i c _a _p) {-# INLINE parsePair #-} @@ -1487,7 +1488,7 @@ instance FromJSON2 Either where | key == left = Left <$> pA value Key left | key == right = Right <$> pB value Key right where - left, right :: Text + left, right :: Key left = "Left" right = "Right" @@ -1802,9 +1803,9 @@ instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Product f g a) wher instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Sum f g) where liftParseJSON p pl (Object (KM.toList -> [(key, value)])) | key == inl = InL <$> liftParseJSON p pl value Key inl - | key == inr = InR <$> liftParseJSON p pl value Key inl + | key == inr = InR <$> liftParseJSON p pl value Key inr where - inl, inr :: Text + inl, inr :: Key inl = "InL" inr = "InR" @@ -1850,11 +1851,11 @@ instance FromJSON a => FromJSON (IntMap.IntMap a) where instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where liftParseJSON p _ = case fromJSONKey of FromJSONKeyCoerce -> withObject "Map" $ - fmap (KM.foldrWithKey (M.insert . unsafeCoerce) M.empty) . KM.traverseWithKey (\k v -> p v Key k) + fmap (KM.foldrWithKey (M.insert . coerce Key.toText) M.empty) . KM.traverseWithKey (\k v -> p v Key k) FromJSONKeyText f -> withObject "Map" $ - fmap (KM.foldrWithKey (M.insert . f) M.empty) . KM.traverseWithKey (\k v -> p v Key k) + fmap (KM.foldrWithKey (M.insert . f . Key.toText) M.empty) . KM.traverseWithKey (\k v -> p v Key k) FromJSONKeyTextParser f -> withObject "Map" $ - KM.foldrWithKey (\k v m -> M.insert <$> f k Key k <*> p v Key k <*> m) (pure M.empty) + KM.foldrWithKey (\k v m -> M.insert <$> f (Key.toText k) Key k <*> p v Key k <*> m) (pure M.empty) FromJSONKeyValue f -> withArray "Map" $ \arr -> fmap M.fromList . Tr.sequence . zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr @@ -1923,16 +1924,17 @@ instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where FromJSONKeyCoerce -> withObject "HashMap ~Text" $ uc . H.traverseWithKey (\k v -> p v Key k) . KM.toHashMap FromJSONKeyText f -> withObject "HashMap" $ - fmap (mapKey f) . H.traverseWithKey (\k v -> p v Key k) . KM.toHashMap + fmap (mapKey (f . Key.toText)) . H.traverseWithKey (\k v -> p v Key k) . KM.toHashMap FromJSONKeyTextParser f -> withObject "HashMap" $ H.foldrWithKey - (\k v m -> H.insert <$> f k Key k <*> p v Key k <*> m) (pure H.empty) + (\k v m -> H.insert <$> f (Key.toText k) Key k <*> p v Key k <*> m) (pure H.empty) . KM.toHashMap FromJSONKeyValue f -> withArray "Map" $ \arr -> fmap H.fromList . Tr.sequence . zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr where - uc :: Parser (H.HashMap Text v) -> Parser (H.HashMap k v) + -- TODO: this is unsafe + uc :: Parser (H.HashMap Key v) -> Parser (H.HashMap k v) uc = unsafeCoerce instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where @@ -1942,6 +1944,13 @@ instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k -- aeson ------------------------------------------------------------------------------- +instance FromJSON Key where + parseJSON = withText "Key" (pure . Key.fromText) + +instance FromJSONKey Key where + -- TODO: make me more efficient. + fromJSONKey = FromJSONKeyText Key.fromText + instance FromJSON Value where parseJSON = pure diff --git a/src/Data/Aeson/Types/Internal.hs b/src/Data/Aeson/Types/Internal.hs index a126b1714..a6a3090fb 100644 --- a/src/Data/Aeson/Types/Internal.hs +++ b/src/Data/Aeson/Types/Internal.hs @@ -29,6 +29,7 @@ module Data.Aeson.Types.Internal ( -- * Core JSON types Value(..) + , Key , Array , emptyArray, isEmptyArray , Pair @@ -89,6 +90,7 @@ import Control.Applicative (Alternative(..)) import Control.DeepSeq (NFData(..)) import Control.Monad (MonadPlus(..), ap) import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum) +import Data.Aeson.Key (Key) import Data.Data (Data) import Data.Foldable (foldl') import Data.Hashable (Hashable(..)) @@ -104,14 +106,14 @@ import GHC.Generics (Generic) import Data.Aeson.KeyMap (KeyMap) import qualified Control.Monad as Monad import qualified Control.Monad.Fail as Fail -import qualified Data.Scientific as S import qualified Data.Vector as V import qualified Language.Haskell.TH.Syntax as TH +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM -- | Elements of a JSON path used to describe the location of an -- error. -data JSONPathElement = Key Text +data JSONPathElement = Key Key -- ^ JSON path element of a key into an object, -- \"object.key\". | Index {-# UNPACK #-} !Int @@ -507,11 +509,11 @@ formatRelativePath path = format "" path format pfx (Index idx:parts) = format (pfx ++ "[" ++ show idx ++ "]") parts format pfx (Key key:parts) = format (pfx ++ formatKey key) parts - formatKey :: Text -> String + formatKey :: Key -> String formatKey key | isIdentifierKey strKey = "." ++ strKey | otherwise = "['" ++ escapeKey strKey ++ "']" - where strKey = unpack key + where strKey = Key.toString key isIdentifierKey :: String -> Bool isIdentifierKey [] = False @@ -526,7 +528,7 @@ formatRelativePath path = format "" path escapeChar c = [c] -- | A key\/value pair for an 'Object'. -type Pair = (Text, Value) +type Pair = (Key, Value) -- | Create a 'Value' from a list of name\/value 'Pair's. If duplicate -- keys arise, later keys and their associated values win. diff --git a/src/Data/Aeson/Types/ToJSON.hs b/src/Data/Aeson/Types/ToJSON.hs index b14d693ee..842c775a7 100644 --- a/src/Data/Aeson/Types/ToJSON.hs +++ b/src/Data/Aeson/Types/ToJSON.hs @@ -66,6 +66,7 @@ import Data.Aeson.Encoding.Internal ((>*<)) import Data.Aeson.Internal.Functions (mapTextKeyVal, mapKeyVal) import Data.Aeson.Types.Generic (AllNullary, False, IsRecord, One, ProductSize, Tagged2(..), True, Zero, productSize) import Data.Aeson.Types.Internal +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as TM import Data.Attoparsec.Number (Number(..)) import Data.Bits (unsafeShiftR) @@ -103,7 +104,7 @@ import Foreign.C.Types (CTime (..)) import GHC.Generics import Numeric.Natural (Natural) import qualified Data.Aeson.Encoding as E -import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding) +import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding, key) import qualified Data.ByteString.Lazy as L import qualified Data.DList as DList #if MIN_VERSION_dlist(1,0,0) && __GLASGOW_HASKELL__ >=800 @@ -325,7 +326,7 @@ class ToJSON a where -- | A key-value pair for encoding a JSON object. class KeyValue kv where - (.=) :: ToJSON v => Text -> v -> kv + (.=) :: ToJSON v => Key -> v -> kv infixr 8 .= instance KeyValue Series where @@ -478,7 +479,7 @@ class ToJSONKey a where toJSONKeyList = ToJSONKeyValue toJSON toEncoding data ToJSONKeyFunction a - = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text) + = ToJSONKeyText !(a -> Key) !(a -> Encoding' Key) -- ^ key is encoded to string, produces object | ToJSONKeyValue !(a -> Value) !(a -> Encoding) -- ^ key is encoded to value, produces array @@ -491,15 +492,16 @@ data ToJSONKeyFunction a -- where -- myKeyToText = Text.pack . show -- or showt from text-show -- @ -toJSONKeyText :: (a -> Text) -> ToJSONKeyFunction a -toJSONKeyText f = ToJSONKeyText f (E.text . f) +toJSONKeyText :: (a -> Key) -> ToJSONKeyFunction a +toJSONKeyText f = ToJSONKeyText f (E.key . f) -- | TODO: should this be exported? -toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a +toJSONKeyTextEnc :: (a -> Encoding' Key) -> ToJSONKeyFunction a toJSONKeyTextEnc e = ToJSONKeyText tot e where -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm - tot = T.dropAround (== '"') + tot = Key.fromText + . T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . E.encodingToLazyByteString @@ -532,7 +534,7 @@ contramapToJSONKeyFunction h x = case x of -- @ genericToJSONKey :: (Generic a, GToJSONKey (Rep a)) => JSONKeyOptions -> ToJSONKeyFunction a -genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from) +genericToJSONKey opts = toJSONKeyText (Key.fromString . keyModifier opts . getConName . from) class GetConName f => GToJSONKey f instance GetConName f => GToJSONKey f @@ -873,7 +875,7 @@ nonAllNullarySumToJSON opts targs = case sumEncoding opts of TaggedObject{..} -> - taggedObject opts targs tagFieldName contentsFieldName + taggedObject opts targs (Key.fromString tagFieldName) (Key.fromString contentsFieldName) ObjectWithSingleField -> (unTagged :: Tagged ObjectWithSingleField enc -> enc) @@ -903,7 +905,7 @@ instance FromString Value where class TaggedObject enc arity f where taggedObject :: Options -> ToArgs enc arity a - -> String -> String + -> Key -> Key -> f a -> enc instance ( TaggedObject enc arity a @@ -937,7 +939,7 @@ instance ( IsRecord a isRecord class TaggedObject' enc pairs arity f isRecord where taggedObject' :: Options -> ToArgs enc arity a - -> String -> f a -> Tagged isRecord pairs + -> Key -> f a -> Tagged isRecord pairs instance ( GToJSON' enc arity f , KeyValuePair enc pairs @@ -1129,7 +1131,7 @@ fieldToPair :: (Selector s => Options -> ToArgs enc arity p -> S1 s a p -> pairs fieldToPair opts targs m1 = - let key = fieldLabelModifier opts (selName m1) + let key = Key.fromString $ fieldLabelModifier opts (selName m1) value = gToJSON opts targs (unM1 m1) in key `pair` value {-# INLINE fieldToPair #-} @@ -1196,7 +1198,7 @@ instance ( GToJSON' enc arity a sumToJSON' opts targs = Tagged . fromPairs . (typ `pair`) . gToJSON opts targs where - typ = constructorTagModifier opts $ + typ = Key.fromString $ constructorTagModifier opts $ conName (undefined :: t c a p) {-# INLINE sumToJSON' #-} @@ -1448,7 +1450,7 @@ instance ToJSON Text where toEncoding = E.text instance ToJSONKey Text where - toJSONKey = toJSONKeyText id + toJSONKey = toJSONKeyText Key.fromText instance ToJSON LT.Text where @@ -1456,7 +1458,7 @@ instance ToJSON LT.Text where toEncoding = E.lazyText instance ToJSONKey LT.Text where - toJSONKey = toJSONKeyText LT.toStrict + toJSONKey = toJSONKeyText (Key.fromText . LT.toStrict) instance ToJSON Version where @@ -1464,7 +1466,7 @@ instance ToJSON Version where toEncoding = toEncoding . showVersion instance ToJSONKey Version where - toJSONKey = toJSONKeyText (T.pack . showVersion) + toJSONKey = toJSONKeyText (Key.fromString . showVersion) ------------------------------------------------------------------------------- -- semigroups NonEmpty @@ -1620,7 +1622,6 @@ instance ToJSON IntSet.IntSet where toJSON = toJSON . IntSet.toList toEncoding = toEncoding . IntSet.toList - instance ToJSON1 IntMap.IntMap where liftToJSON t tol = liftToJSON to' tol' . IntMap.toList where @@ -1684,7 +1685,7 @@ instance ToJSON UUID.UUID where toEncoding = E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes instance ToJSONKey UUID.UUID where - toJSONKey = ToJSONKeyText UUID.toText $ + toJSONKey = ToJSONKeyText (Key.fromText . UUID.toText) $ E.unsafeToEncoding . EB.quote . B.byteString . UUID.toASCIIBytes ------------------------------------------------------------------------------- @@ -1759,8 +1760,7 @@ instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where instance ToJSON1 TM.KeyMap where liftToJSON g _ = Object . fmap g - - liftToEncoding g _ = dict E.text g TM.foldrWithKey + liftToEncoding g _ = dict E.key g TM.foldrWithKey instance (ToJSON v) => ToJSON (TM.KeyMap v) where {-# SPECIALIZE instance ToJSON Object #-} @@ -1772,6 +1772,13 @@ instance (ToJSON v) => ToJSON (TM.KeyMap v) where -- aeson ------------------------------------------------------------------------------- +instance ToJSON Key where + toJSON = toJSON . Key.toText + toEncoding = E.key + +instance ToJSONKey Key where + toJSONKey = ToJSONKeyText id E.key + instance ToJSON Value where toJSON a = a toEncoding = E.value @@ -2194,8 +2201,8 @@ instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c) instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d) instance ToJSONKey Char where - toJSONKey = ToJSONKeyText T.singleton (E.string . (:[])) - toJSONKeyList = toJSONKeyText T.pack + toJSONKey = ToJSONKeyText (Key.fromText . T.singleton) (E.key . Key.fromText . T.singleton) + toJSONKeyList = toJSONKeyText Key.fromString instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where toJSONKey = toJSONKeyList @@ -2681,12 +2688,12 @@ instance FromPairs Value (DList Pair) where -- ('Value' or 'Encoding'), and the result actually represents lists of pairs -- so it can be readily concatenated. class Monoid kv => KeyValuePair v kv where - pair :: String -> v -> kv + pair :: Key -> v -> kv instance (v ~ Value) => KeyValuePair v (DList Pair) where - pair k v = DList.singleton (pack k .= v) + pair k v = DList.singleton (k .= v) {-# INLINE pair #-} instance (e ~ Encoding) => KeyValuePair e Series where - pair = E.pairStr + pair = E.pair {-# INLINE pair #-} diff --git a/tests/Encoders.hs b/tests/Encoders.hs index 8bcab3cfb..5fef3d9f0 100644 --- a/tests/Encoders.hs +++ b/tests/Encoders.hs @@ -6,10 +6,10 @@ module Encoders (module Encoders) where import Prelude.Compat -import Data.Text (Text) import Data.Aeson.TH import Data.Aeson.Types +import qualified Data.Aeson.Key as Key import Options import Types @@ -100,14 +100,14 @@ gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleFi keyOptions :: JSONKeyOptions keyOptions = defaultJSONKeyOptions { keyModifier = ('k' :) } -gNullaryToJSONKey :: Nullary -> Either String Text +gNullaryToJSONKey :: Nullary -> Either String Key gNullaryToJSONKey x = case genericToJSONKey keyOptions of ToJSONKeyText p _ -> Right (p x) _ -> Left "Should be a ToJSONKeyText" -gNullaryFromJSONKey :: Text -> Parser Nullary +gNullaryFromJSONKey :: Key -> Parser Nullary gNullaryFromJSONKey t = case genericFromJSONKey keyOptions of - FromJSONKeyTextParser p -> p t + FromJSONKeyTextParser p -> p (Key.toText t) _ -> fail "Not a TextParser" -------------------------------------------------------------------------------- diff --git a/tests/Instances.hs b/tests/Instances.hs index f683b7f36..f4045f0cb 100644 --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -20,6 +20,7 @@ import Data.Time.Clock (UTCTime(..)) import Functions import Test.QuickCheck (Arbitrary(..), elements, oneof, sized, Gen, chooseInt, shuffle) import Types +import qualified Data.Aeson.Key as Key import qualified Data.DList as DList import qualified Data.Vector as V import qualified Data.HashMap.Strict as HM @@ -168,6 +169,9 @@ instance (ApproxEq a) => ApproxEq [a] where instance Arbitrary a => Arbitrary (DList.DList a) where arbitrary = DList.fromList <$> arbitrary +instance Arbitrary Key where + arbitrary = Key.fromText <$> arbitrary + instance Arbitrary Value where arbitrary = sized arb where arb :: Int -> Gen Value diff --git a/tests/PropUtils.hs b/tests/PropUtils.hs index ac7325931..4d776984d 100644 --- a/tests/PropUtils.hs +++ b/tests/PropUtils.hs @@ -12,6 +12,7 @@ import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse) import qualified Data.Aeson.Internal as I import Data.Aeson.Parser (value) import Data.Aeson.Types +import qualified Data.Aeson.Key as Key import qualified Data.Aeson.KeyMap as KM import Data.HashMap.Strict (HashMap) import Data.Hashable (Hashable) @@ -124,7 +125,7 @@ parserCatchErrorProp path msg = result :: Result (I.JSONPath, String) result = parse (const parser) () - jsonPath = map (I.Key . T.pack) path + jsonPath = map (I.Key . Key.fromString) path -- | Perform a structural comparison of the results of two encoding -- methods. Compares decoded values to account for HashMap-driven