git.iko.soy/typeable/aeson
on master help sign in
fixed merge conflicts
652d301Andrew Martin
Data/Aeson.hs+10−1
compare with master
unifiedsplit
@@ -108,8 +108,11 @@ module Data.Aeson
108 , json'
108 , json'
109 ) where
109 ) where
110
110
111+import Prelude ()
112+import Prelude.Compat (Maybe, either, Either(..), uncurry, String, (.))
113+
111import Data.Aeson.Types.FromJSON (ifromJSON)
114import Data.Aeson.Types.FromJSON (ifromJSON)
112−import Data.Aeson.Encode (encode)
115+import Data.Aeson.Encoding (encodingToLazyByteString)
113import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith,
116import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith,
114 eitherDecodeWith, eitherDecodeStrictWith,
117 eitherDecodeWith, eitherDecodeStrictWith,
115 jsonEOF, json, jsonEOF', json')
118 jsonEOF, json, jsonEOF', json')
@@ -118,6 +121,12 @@ import Data.Aeson.Types.Internal (JSONPath, formatError)
118import qualified Data.ByteString as B
121import qualified Data.ByteString as B
119import qualified Data.ByteString.Lazy as L
122import qualified Data.ByteString.Lazy as L
120
123
124+-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
125+--
126+-- This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.
127+encode :: (ToJSON a) => a -> L.ByteString
128+encode = encodingToLazyByteString . toEncoding
129+
121-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.
130-- | Efficiently deserialize a JSON value from a lazy 'L.ByteString'.
122-- If this fails due to incomplete or invalid input, 'Nothing' is
131-- If this fails due to incomplete or invalid input, 'Nothing' is
123-- returned.
132-- returned.
Data/Aeson/Encode.hs+12−94
@@ -1,5 +1,3 @@
1−{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2−
3-- |
1-- |
4-- Module: Data.Aeson.Encode
2-- Module: Data.Aeson.Encode
5-- Copyright: (c) 2012-2016 Bryan O'Sullivan
3-- Copyright: (c) 2012-2016 Bryan O'Sullivan
@@ -9,102 +7,22 @@
9-- Stability: experimental
7-- Stability: experimental
10-- Portability: portable
8-- Portability: portable
11--
9--
12−-- Efficiently serialize a JSON value.
10+-- This module is left to supply limited backwards-compatibility.
13−--
14−-- Most frequently, you'll probably want to encode straight to UTF-8
15−-- (the standard JSON encoding) using 'encode'.
16−--
17−-- You can use the conversions to 'Builder's when embedding JSON messages as
18−-- parts of a protocol.
19−module Data.Aeson.Encode
11+module Data.Aeson.Encode {-# DEPRECATED "Use Data.Aeson or Data.Aeson.Text instead" #-}
20 ( encode
12 ( encode
21−
22− -- * Encoding to Builders
23− , encodeToBuilder
24 , encodeToTextBuilder
13 , encodeToTextBuilder
25−
26− -- * Deprecated
27− , fromValue
28 ) where
14 ) where
29
15
30−import Data.Aeson.Encode.Builder (encodeToBuilder)
16+import Data.ByteString.Lazy (ByteString)
31−import Data.Aeson.Types (Value(..), ToJSON (..))
32−import Data.Aeson.Encoding (fromEncoding)
33−import Data.Monoid ((<>))
34−import Data.Scientific (FPFormat(..), Scientific, base10Exponent)
35−import Data.Text.Lazy.Builder
17+import Data.Text.Lazy.Builder (Builder)
36−import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
37−
38−import Numeric (showHex)
39−import qualified Data.ByteString.Builder as B
40−import qualified Data.HashMap.Strict as H
41−import qualified Data.Text as T
42−import qualified Data.Vector as V
43−import qualified Data.ByteString.Lazy as L
44−
45−-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
46−--
47−-- This is implemented in terms of the 'ToJSON' class's 'toEncoding' method.
48−encode :: ToJSON a => a -> L.ByteString
49−encode = B.toLazyByteString . fromEncoding . toEncoding
50−{-# INLINE encode #-}
51−
52−-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be
53−-- embedded efficiently in a text-based protocol.
54−--
55−-- If you are going to immediately encode straight to a
56−-- 'L.ByteString', it is more efficient to use 'encodeToBuilder'
57−-- instead.
58−encodeToTextBuilder :: Value -> Builder
59−encodeToTextBuilder =
60− go
61− where
62− go Null = {-# SCC "go/Null" #-} "null"
63− go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false"
64− go (Number s) = {-# SCC "go/Number" #-} fromScientific s
65− go (String s) = {-# SCC "go/String" #-} string s
66− go (Array v)
67− | V.null v = {-# SCC "go/Array" #-} "[]"
68− | otherwise = {-# SCC "go/Array" #-}
69− singleton '[' <>
70− go (V.unsafeHead v) <>
71− V.foldr f (singleton ']') (V.unsafeTail v)
72− where f a z = singleton ',' <> go a <> z
73− go (Object m) = {-# SCC "go/Object" #-}
74− case H.toList m of
75− (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs
76− _ -> "{}"
77− where f a z = singleton ',' <> one a <> z
78− one (k,v) = string k <> singleton ':' <> go v
79−
80−{-# DEPRECATED fromValue "Use 'encodeToTextBuilder' instead" #-}
81−fromValue :: Value -> Builder
82−fromValue = encodeToTextBuilder
83
18
84−string :: T.Text -> Builder
19+import qualified Data.Aeson as A
85−string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'
20+import qualified Data.Aeson.Text as A
86− where
87− quote q = case T.uncons t of
88− Nothing -> fromText h
89− Just (!c,t') -> fromText h <> escape c <> quote t'
90− where (h,t) = {-# SCC "break" #-} T.break isEscape q
91− isEscape c = c == '\"' ||
92− c == '\\' ||
93− c < '\x20'
94− escape '\"' = "\\\""
95− escape '\\' = "\\\\"
96− escape '\n' = "\\n"
97− escape '\r' = "\\r"
98− escape '\t' = "\\t"
99
21
100− escape c
22+encode :: A.ToJSON a => a -> ByteString
101− | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h
23+encode = A.encode
102− | otherwise = singleton c
24+{-# DEPRECATED encode "Use encode from Data.Aeson" #-}
103− where h = showHex (fromEnum c) ""
104
25
105−fromScientific :: Scientific -> Builder
26+encodeToTextBuilder :: A.Value -> Builder
106−fromScientific s = formatScientificBuilder format prec s
27+encodeToTextBuilder = A.encodeToTextBuilder
107− where
28+{-# DEPRECATED encodeToTextBuilder "Use encodeTotextBuilder from Data.Aeson.Text" #-}
108− (format, prec)
109− | base10Exponent s < 0 = (Generic, Nothing)
110− | otherwise = (Fixed, Just 0)
Data/Aeson/Encode/Functions.hsdeleted−14
@@ -1,14 +0,0 @@
1−{-# LANGUAGE CPP #-}
2−
3−module Data.Aeson.Encode.Functions
4− (
5− builder
6− ) where
7−
8−import Data.Aeson.Encoding
9−import Data.Aeson.Types.Class
10−import Data.ByteString.Builder (Builder)
11−import Data.Monoid ((<>))
12−
13−
14−{-# INLINE builder #-}
Data/Aeson/Encoding.hs+7
@@ -1,7 +1,14 @@
1+-- |
2+--
3+-- Functions in this module return well-formed 'Encoding''.
4+-- Polymorphic variants, which return @'Encoding' a@, return a textual JSON
5+-- value, so it can be used as both @'Encoding'' 'Text'@ and @'Encoding' = 'Encoding'' 'Value'@.
1module Data.Aeson.Encoding
6module Data.Aeson.Encoding
2 (
7 (
3 -- * Encoding
8 -- * Encoding
4 Encoding
9 Encoding
10+ , Encoding'
11+ , encodingToLazyByteString
5 , fromEncoding
12 , fromEncoding
6 , unsafeToEncoding
13 , unsafeToEncoding
7 , Series
14 , Series
Data/Aeson/Encode/Builder.hs → Data/Aeson/Encoding/Builder.hsrenamed+5−2
@@ -1,7 +1,7 @@
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
1{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2
2
3-- |
3-- |
4−-- Module: Data.Aeson.Encode.Builder
4+-- Module: Data.Aeson.Encoding.Builder
5-- Copyright: (c) 2011 MailRank, Inc.
5-- Copyright: (c) 2011 MailRank, Inc.
6-- (c) 2013 Simon Meier <iridcode@gmail.com>
6-- (c) 2013 Simon Meier <iridcode@gmail.com>
7-- License: BSD3
7-- License: BSD3
@@ -11,7 +11,7 @@
11--
11--
12-- Efficiently serialize a JSON value using the UTF-8 encoding.
12-- Efficiently serialize a JSON value using the UTF-8 encoding.
13
13
14−module Data.Aeson.Encode.Builder
14+module Data.Aeson.Encoding.Builder
15 (
15 (
16 encodeToBuilder
16 encodeToBuilder
17 , null_
17 , null_
@@ -35,6 +35,9 @@ module Data.Aeson.Encode.Builder
35 , ascii5
35 , ascii5
36 ) where
36 ) where
37
37
38+import Prelude ()
39+import Prelude.Compat
40+
38import Data.Aeson.Internal.Time
41import Data.Aeson.Internal.Time
39import Data.Aeson.Types.Internal (Value (..))
42import Data.Aeson.Types.Internal (Value (..))
40import Data.ByteString.Builder as B
43import Data.ByteString.Builder as B
Data/Aeson/Encoding/Internal.hs+95−70
@@ -1,13 +1,16 @@
1−{-# LANGUAGE DeriveDataTypeable #-}
1+{-# LANGUAGE DeriveDataTypeable #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3−{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE OverloadedStrings #-}
4−{-# LANGUAGE RankNTypes #-}
4+{-# LANGUAGE RankNTypes #-}
5module Data.Aeson.Encoding.Internal
5module Data.Aeson.Encoding.Internal
6 (
6 (
7 -- * Encoding
7 -- * Encoding
8− Encoding (..) -- TODO: export fromEncoding for now
8+ Encoding' (..)
9+ , Encoding
10+ , encodingToLazyByteString
9 , unsafeToEncoding
11 , unsafeToEncoding
10− , Series (..) -- TODO: don't export constructor
12+ , retagEncoding
13+ , Series (..)
11 , pairs
14 , pairs
12 , pair
15 , pair
13 -- * Predicates
16 -- * Predicates
@@ -15,8 +18,8 @@ module Data.Aeson.Encoding.Internal
15 -- * Encoding constructors
18 -- * Encoding constructors
16 , emptyArray_
19 , emptyArray_
17 , emptyObject_
20 , emptyObject_
18− , wrapArray
19 , wrapObject
21 , wrapObject
22+ , wrapArray
20 , null_
23 , null_
21 , bool
24 , bool
22 , text
25 , text
@@ -26,6 +29,10 @@ module Data.Aeson.Encoding.Internal
26 , dict
29 , dict
27 , tuple
30 , tuple
28 , (>*<)
31 , (>*<)
32+ , InArray
33+ , empty
34+ , (><)
35+ , econcat
29 -- ** Decimal numbers
36 -- ** Decimal numbers
30 , int8, int16, int32, int64, int
37 , int8, int16, int32, int64, int
31 , word8, word16, word32, word64, word
38 , word8, word16, word32, word64, word
@@ -62,35 +69,48 @@ import Data.Word
62
69
63import Data.Aeson.Types.Internal (Value)
70import Data.Aeson.Types.Internal (Value)
64
71
65−import qualified Data.Aeson.Encode.Builder as EB
72+import qualified Data.Aeson.Encoding.Builder as EB
66−import qualified Data.ByteString.Builder as B
73+import qualified Data.ByteString.Builder as B
67−import qualified Data.ByteString.Lazy as BSL
74+import qualified Data.ByteString.Lazy as BSL
68−import qualified Data.Text.Lazy as LT
75+import qualified Data.Text.Lazy as LT
69
76
70-- | An encoding of a JSON value.
77-- | An encoding of a JSON value.
78+--
79+-- @tag@ represents which kind of JSON the Encoding is encoding to,
80+-- we reuse 'Text' and 'Value' as tags here.
71−newtype Encoding = Encoding {
81+newtype Encoding' tag = Encoding {
72 fromEncoding :: Builder
82 fromEncoding :: Builder
73 -- ^ Acquire the underlying bytestring builder.
83 -- ^ Acquire the underlying bytestring builder.
74− } deriving (Semigroup,Monoid,Typeable)
84+ } deriving (Typeable)
85+
86+-- | Often used synonnym for 'Encoding''.
87+type Encoding = Encoding' Value
75
88
76-- | Make Encoding from Builder.
89-- | Make Encoding from Builder.
77--
90--
78-- Use with care! You have to make sure that the passed Builder
91-- Use with care! You have to make sure that the passed Builder
79-- is a valid JSON Encoding!
92-- is a valid JSON Encoding!
80−unsafeToEncoding :: Builder -> Encoding
93+unsafeToEncoding :: Builder -> Encoding' a
81unsafeToEncoding = Encoding
94unsafeToEncoding = Encoding
82
95
96+encodingToLazyByteString :: Encoding' a -> BSL.ByteString
97+encodingToLazyByteString = toLazyByteString . fromEncoding
98+{-# INLINE encodingToLazyByteString #-}
99+
100+retagEncoding :: Encoding' a -> Encoding' b
101+retagEncoding = Encoding . fromEncoding
102+
83-------------------------------------------------------------------------------
103-------------------------------------------------------------------------------
84-- Encoding instances
104-- Encoding instances
85-------------------------------------------------------------------------------
105-------------------------------------------------------------------------------
86
106
87−instance Show Encoding where
107+instance Show (Encoding' a) where
88 show (Encoding e) = show (toLazyByteString e)
108 show (Encoding e) = show (toLazyByteString e)
89
109
90−instance Eq Encoding where
110+instance Eq (Encoding' a) where
91 Encoding a == Encoding b = toLazyByteString a == toLazyByteString b
111 Encoding a == Encoding b = toLazyByteString a == toLazyByteString b
92
112
93−instance Ord Encoding where
113+instance Ord (Encoding' a) where
94 compare (Encoding a) (Encoding b) =
114 compare (Encoding a) (Encoding b) =
95 compare (toLazyByteString a) (toLazyByteString b)
115 compare (toLazyByteString a) (toLazyByteString b)
96
116
@@ -102,25 +122,22 @@ instance Ord Encoding where
102--
122--
103-- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age)
123-- > toEncoding (Person name age) = pairs ("name" .= name <> "age" .= age)
104data Series = Empty
124data Series = Empty
105− | Value Encoding
125+ | Value (Encoding' Series)
106 deriving (Typeable)
126 deriving (Typeable)
107
127
108pair :: Text -> Encoding -> Series
128pair :: Text -> Encoding -> Series
109−pair name val = Value $ text name <> colon <> val
129+pair name val = Value $ retagEncoding $ text name >< colon >< val
110
130
111instance Semigroup Series where
131instance Semigroup Series where
112− Empty <> a = a
132+ Empty <> a = a
113− Value a <> b =
133+ a <> Empty = a
114− Value $
134+ Value a <> Value b = Value (a >< comma >< b)
115− a <> case b of
116− Empty -> mempty
117− Value c -> Encoding (char7 ',') <> c
118
135
119instance Monoid Series where
136instance Monoid Series where
120 mempty = Empty
137 mempty = Empty
121 mappend = (<>)
138 mappend = (<>)
122
139
123−nullEncoding :: Encoding -> Bool
140+nullEncoding :: Encoding' a -> Bool
124nullEncoding = BSL.null . toLazyByteString . fromEncoding
141nullEncoding = BSL.null . toLazyByteString . fromEncoding
125
142
126emptyArray_ :: Encoding
143emptyArray_ :: Encoding
@@ -129,11 +146,11 @@ emptyArray_ = Encoding EB.emptyArray_
129emptyObject_ :: Encoding
146emptyObject_ :: Encoding
130emptyObject_ = Encoding EB.emptyObject_
147emptyObject_ = Encoding EB.emptyObject_
131
148
132−wrapArray :: Encoding -> Encoding
149+wrapArray :: Encoding' a -> Encoding
133−wrapArray e = openBracket <> e <> closeBracket
150+wrapArray e = retagEncoding $ openBracket >< e >< closeBracket
134
151
135−wrapObject :: Encoding -> Encoding
152+wrapObject :: Encoding' a -> Encoding
136−wrapObject e = openCurly <> e <> closeCurly
153+wrapObject e = retagEncoding $ openCurly >< e >< closeCurly
137
154
138null_ :: Encoding
155null_ :: Encoding
139null_ = Encoding EB.null_
156null_ = Encoding EB.null_
@@ -144,41 +161,50 @@ bool False = Encoding "false"
144
161
145-- | Encode a series of key/value pairs, separated by commas.
162-- | Encode a series of key/value pairs, separated by commas.
146pairs :: Series -> Encoding
163pairs :: Series -> Encoding
147−pairs = brackets '{' '}'
164+pairs (Value v) = openCurly >< retagEncoding v >< closeCurly
165+pairs Empty = emptyObject_
148{-# INLINE pairs #-}
166{-# INLINE pairs #-}
149
167
150−brackets :: Char -> Char -> Series -> Encoding
151−brackets begin end (Value v) = Encoding $
152− char7 begin <> fromEncoding v <> char7 end
153−brackets begin end Empty = Encoding (primBounded (EB.ascii2 (begin,end)) ())
154−
155list :: (a -> Encoding) -> [a] -> Encoding
168list :: (a -> Encoding) -> [a] -> Encoding
156list _ [] = emptyArray_
169list _ [] = emptyArray_
157−list to' (x:xs) = Encoding $
170+list to' (x:xs) = openBracket >< to' x >< commas xs >< closeBracket
158− char7 '[' <> fromEncoding (to' x) <> commas xs <> char7 ']'
159 where
171 where
160− commas = foldr (\v vs -> char7 ',' <> fromEncoding (to' v) <> vs) mempty
172+ commas = foldr (\v vs -> comma >< to' v >< vs) empty
161{-# INLINE list #-}
173{-# INLINE list #-}
162
174
163-- | Encode as JSON object
175-- | Encode as JSON object
164dict
176dict
165− :: (k -> Encoding) -- ^ key encoding
177+ :: (k -> Encoding' Text) -- ^ key encoding
166 -> (v -> Encoding) -- ^ value encoding
178 -> (v -> Encoding) -- ^ value encoding
167 -> (forall a. (k -> v -> a -> a) -> a -> m -> a) -- ^ @foldrWithKey@ - indexed fold
179 -> (forall a. (k -> v -> a -> a) -> a -> m -> a) -- ^ @foldrWithKey@ - indexed fold
168 -> m -- ^ container
180 -> m -- ^ container
169 -> Encoding
181 -> Encoding
170−dict encodeKey encodeVal foldrWithKey = brackets '{' '}' . foldrWithKey go mempty
182+dict encodeKey encodeVal foldrWithKey = pairs . foldrWithKey go mempty
171 where
183 where
172 go k v c = Value (encodeKV k v) <> c
184 go k v c = Value (encodeKV k v) <> c
173− encodeKV k v = encodeKey k <> Encoding (char7 ':') <> encodeVal v
185+ encodeKV k v = retagEncoding (encodeKey k) >< colon >< retagEncoding (encodeVal v)
174{-# INLINE dict #-}
186{-# INLINE dict #-}
175
187
188+-- | Type tag for tuples contents, see 'tuple'.
189+data InArray
190+
176infixr 6 >*<
191infixr 6 >*<
177-- | See 'tuple'.
192-- | See 'tuple'.
178−(>*<) :: Encoding -> Encoding -> Encoding
193+(>*<) :: Encoding' a -> Encoding' b -> Encoding' InArray
179−Encoding a >*< Encoding b = Encoding $ a <> char7 ',' <> b
194+a >*< b = retagEncoding a >< comma >< retagEncoding b
180{-# INLINE (>*<) #-}
195{-# INLINE (>*<) #-}
181
196
197+empty :: Encoding' a
198+empty = Encoding mempty
199+
200+econcat :: [Encoding' a] -> Encoding' a
201+econcat = foldr (><) empty
202+
203+infixr 6 ><
204+(><) :: Encoding' a -> Encoding' a -> Encoding' a
205+Encoding a >< Encoding b = Encoding (a <> b)
206+{-# INLINE (><) #-}
207+
182-- | Encode as a tuple.
208-- | Encode as a tuple.
183--
209--
184-- @
210-- @
@@ -186,26 +212,26 @@ Encoding a >*< Encoding b = Encoding $ a <> char7 ',' <> b
186-- toEncoding a >*<
212-- toEncoding a >*<
187-- toEncoding b >*<
213-- toEncoding b >*<
188-- toEncoding c
214-- toEncoding c
189−tuple :: Encoding -> Encoding
215+tuple :: Encoding' InArray -> Encoding
190−tuple b = Encoding (char7 '[' <> fromEncoding b <> char7 ']')
216+tuple b = retagEncoding $ openBracket >< b >< closeBracket
191{-# INLINE tuple #-}
217{-# INLINE tuple #-}
192
218
193−text :: Text -> Encoding
219+text :: Text -> Encoding' a
194text = Encoding . EB.text
220text = Encoding . EB.text
195
221
196−lazyText :: LT.Text -> Encoding
222+lazyText :: LT.Text -> Encoding' a
197lazyText t = Encoding $
223lazyText t = Encoding $
198 B.char7 '"' <>
224 B.char7 '"' <>
199 LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t
225 LT.foldrChunks (\x xs -> EB.unquoted x <> xs) (B.char7 '"') t
200
226
201−string :: String -> Encoding
227+string :: String -> Encoding' a
202string = Encoding . EB.string
228string = Encoding . EB.string
203
229
204-------------------------------------------------------------------------------
230-------------------------------------------------------------------------------
205-- chars
231-- chars
206-------------------------------------------------------------------------------
232-------------------------------------------------------------------------------
207
233
208−comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding
234+comma, colon, openBracket, closeBracket, openCurly, closeCurly :: Encoding' a
209comma = Encoding $ char7 ','
235comma = Encoding $ char7 ','
210colon = Encoding $ char7 ':'
236colon = Encoding $ char7 ':'
211openBracket = Encoding $ char7 '['
237openBracket = Encoding $ char7 '['
@@ -269,66 +295,65 @@ realFloatToEncoding e d
269-- Decimal numbers as Text
295-- Decimal numbers as Text
270-------------------------------------------------------------------------------
296-------------------------------------------------------------------------------
271
297
272−int8Text :: Int8 -> Encoding
298+int8Text :: Int8 -> Encoding' a
273int8Text = Encoding . EB.quote . B.int8Dec
299int8Text = Encoding . EB.quote . B.int8Dec
274
300
275−int16Text :: Int16 -> Encoding
301+int16Text :: Int16 -> Encoding' a
276int16Text = Encoding . EB.quote . B.int16Dec
302int16Text = Encoding . EB.quote . B.int16Dec
277
303
278−int32Text :: Int32 -> Encoding
304+int32Text :: Int32 -> Encoding' a
279int32Text = Encoding . EB.quote . B.int32Dec
305int32Text = Encoding . EB.quote . B.int32Dec
280
306
281−int64Text :: Int64 -> Encoding
307+int64Text :: Int64 -> Encoding' a
282int64Text = Encoding . EB.quote . B.int64Dec
308int64Text = Encoding . EB.quote . B.int64Dec
283
309
284−intText :: Int -> Encoding
310+intText :: Int -> Encoding' a
285intText = Encoding . EB.quote . B.intDec
311intText = Encoding . EB.quote . B.intDec
286
312
287−word8Text :: Word8 -> Encoding
313+word8Text :: Word8 -> Encoding' a
288word8Text = Encoding . EB.quote . B.word8Dec
314word8Text = Encoding . EB.quote . B.word8Dec
289
315
290−word16Text :: Word16 -> Encoding
316+word16Text :: Word16 -> Encoding' a
291word16Text = Encoding . EB.quote . B.word16Dec
317word16Text = Encoding . EB.quote . B.word16Dec
292
318
293−word32Text :: Word32 -> Encoding
319+word32Text :: Word32 -> Encoding' a
294word32Text = Encoding . EB.quote . B.word32Dec
320word32Text = Encoding . EB.quote . B.word32Dec
295
321
296−word64Text :: Word64 -> Encoding
322+word64Text :: Word64 -> Encoding' a
297word64Text = Encoding . EB.quote . B.word64Dec
323word64Text = Encoding . EB.quote . B.word64Dec
298
324
299−wordText :: Word -> Encoding
325+wordText :: Word -> Encoding' a
300wordText = Encoding . EB.quote . B.wordDec
326wordText = Encoding . EB.quote . B.wordDec
301
327
302−integerText :: Integer -> Encoding
328+integerText :: Integer -> Encoding' a
303integerText = Encoding . EB.quote . B.integerDec
329integerText = Encoding . EB.quote . B.integerDec
304
330
305−-- | TODO: check infinite and nan?
306−floatText :: Float -> Encoding
331+floatText :: Float -> Encoding' a
307floatText = Encoding . EB.quote . B.floatDec
332floatText = Encoding . EB.quote . B.floatDec
308
333
309−doubleText :: Double -> Encoding
334+doubleText :: Double -> Encoding' a
310doubleText = Encoding . EB.quote . B.doubleDec
335doubleText = Encoding . EB.quote . B.doubleDec
311
336
312−scientificText :: Scientific -> Encoding
337+scientificText :: Scientific -> Encoding' a
313scientificText = Encoding . EB.quote . EB.scientific
338scientificText = Encoding . EB.quote . EB.scientific
314
339
315-------------------------------------------------------------------------------
340-------------------------------------------------------------------------------
316-- time
341-- time
317-------------------------------------------------------------------------------
342-------------------------------------------------------------------------------
318
343
319−day :: Day -> Encoding
344+day :: Day -> Encoding' a
320day = Encoding . EB.quote . EB.day
345day = Encoding . EB.quote . EB.day
321
346
322−localTime :: LocalTime -> Encoding
347+localTime :: LocalTime -> Encoding' a
323localTime = Encoding . EB.quote . EB.localTime
348localTime = Encoding . EB.quote . EB.localTime
324
349
325−utcTime :: UTCTime -> Encoding
350+utcTime :: UTCTime -> Encoding' a
326utcTime = Encoding . EB.quote . EB.utcTime
351utcTime = Encoding . EB.quote . EB.utcTime
327
352
328−timeOfDay :: TimeOfDay -> Encoding
353+timeOfDay :: TimeOfDay -> Encoding' a
329timeOfDay = Encoding . EB.quote . EB.timeOfDay
354timeOfDay = Encoding . EB.quote . EB.timeOfDay
330
355
331−zonedTime :: ZonedTime -> Encoding
356+zonedTime :: ZonedTime -> Encoding' a
332zonedTime = Encoding . EB.quote . EB.zonedTime
357zonedTime = Encoding . EB.quote . EB.zonedTime
333
358
334-------------------------------------------------------------------------------
359-------------------------------------------------------------------------------
Data/Aeson/Functions.hs → Data/Aeson/Internal/Functions.hsrenamed+4−8
@@ -7,13 +7,15 @@
7-- Stability: experimental
7-- Stability: experimental
8-- Portability: portable
8-- Portability: portable
9
9
10−module Data.Aeson.Functions
10+module Data.Aeson.Internal.Functions
11 ( mapHashKeyVal
11 ( mapHashKeyVal
12− , hashMapKey
13 , mapKeyVal
12 , mapKeyVal
14 , mapKey
13 , mapKey
15 ) where
14 ) where
16
15
16+import Prelude ()
17+import Prelude.Compat
18+
17import Data.Hashable (Hashable)
19import Data.Hashable (Hashable)
18import qualified Data.HashMap.Strict as H
20import qualified Data.HashMap.Strict as H
19import qualified Data.Map as M
21import qualified Data.Map as M
@@ -24,12 +26,6 @@ mapHashKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
24mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
26mapHashKeyVal fk kv = M.foldrWithKey (\k v -> H.insert (fk k) (kv v)) H.empty
25{-# INLINE mapHashKeyVal #-}
27{-# INLINE mapHashKeyVal #-}
26
28
27−-- | Transform a 'M.Map' into a 'H.HashMap' while transforming the keys.
28−hashMapKey :: (Ord k2) => (k1 -> k2)
29− -> H.HashMap k1 v -> M.Map k2 v
30−hashMapKey kv = H.foldrWithKey (M.insert . kv) M.empty
31−{-# INLINE hashMapKey #-}
32−
33-- | Transform the keys and values of a 'H.HashMap'.
29-- | Transform the keys and values of a 'H.HashMap'.
34mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
30mapKeyVal :: (Eq k2, Hashable k2) => (k1 -> k2) -> (v1 -> v2)
35 -> H.HashMap k1 v1 -> H.HashMap k2 v2
31 -> H.HashMap k1 v1 -> H.HashMap k2 v2
Data/Aeson/Internal/Time.hs+3
@@ -17,6 +17,9 @@ module Data.Aeson.Internal.Time
17 , toTimeOfDay64
17 , toTimeOfDay64
18 ) where
18 ) where
19
19
20+import Prelude ()
21+import Prelude.Compat
22+
20import Data.Fixed (Pico)
23import Data.Fixed (Pico)
21import Data.Int (Int64)
24import Data.Int (Int64)
22import Data.Time
25import Data.Time
Data/Aeson/Parser/Internal.hs+3−4
@@ -31,6 +31,9 @@ module Data.Aeson.Parser.Internal
31 , eitherDecodeStrictWith
31 , eitherDecodeStrictWith
32 ) where
32 ) where
33
33
34+import Prelude ()
35+import Prelude.Compat
36+
34import Control.Monad.IO.Class (liftIO)
37import Control.Monad.IO.Class (liftIO)
35import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
38import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))
36import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,
39import Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, scientific,
@@ -58,10 +61,6 @@ import qualified Data.ByteString.Lazy as L
58import qualified Data.ByteString.Unsafe as B
61import qualified Data.ByteString.Unsafe as B
59import qualified Data.HashMap.Strict as H
62import qualified Data.HashMap.Strict as H
60
63
61−#if !MIN_VERSION_base(4,8,0)
62−import Control.Applicative ((*>), (<$>), (<*), pure)
63−#endif
64−
65#if MIN_VERSION_ghc_prim(0,3,1)
64#if MIN_VERSION_ghc_prim(0,3,1)
66import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#)
65import GHC.Base (Int#, (==#), isTrue#, orI#, word2Int#)
67import GHC.Word (Word8(W8#))
66import GHC.Word (Word8(W8#))
Data/Aeson/Parser/Time.hs+4−5
@@ -1,4 +1,4 @@
1−{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}
1+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
2
2
3-- |
3-- |
4-- Module: Data.Aeson.Parser.Time
4-- Module: Data.Aeson.Parser.Time
@@ -21,6 +21,9 @@ module Data.Aeson.Parser.Time
21 , zonedTime
21 , zonedTime
22 ) where
22 ) where
23
23
24+import Prelude ()
25+import Prelude.Compat
26+
24import Control.Monad (when, void)
27import Control.Monad (when, void)
25import Data.Aeson.Internal.Time (toPico)
28import Data.Aeson.Internal.Time (toPico)
26import Data.Attoparsec.Text as A
29import Data.Attoparsec.Text as A
@@ -36,10 +39,6 @@ import qualified Data.Aeson.Types.Internal as Aeson
36import qualified Data.Text as T
39import qualified Data.Text as T
37import qualified Data.Time.LocalTime as Local
40import qualified Data.Time.LocalTime as Local
38
41
39−#if !MIN_VERSION_base(4,8,0)
40−import Control.Applicative ((<$>), (<*>), (<*), (*>))
41−#endif
42−
43-- | Run an attoparsec parser as an aeson parser.
42-- | Run an attoparsec parser as an aeson parser.
44run :: Parser a -> Text -> Aeson.Parser a
43run :: Parser a -> Text -> Aeson.Parser a
45run p t = case A.parseOnly (p <* endOfInput) t of
44run p t = case A.parseOnly (p <* endOfInput) t of
Data/Aeson/TH.hs+4−5
@@ -141,7 +141,6 @@ import Data.List ( (++), all, any, find, foldl, foldl'
141import Data.List.NonEmpty ( NonEmpty((:|)), (<|) )
141import Data.List.NonEmpty ( NonEmpty((:|)), (<|) )
142import Data.Map ( Map )
142import Data.Map ( Map )
143import Data.Maybe ( Maybe(Nothing, Just), catMaybes, fromMaybe, mapMaybe )
143import Data.Maybe ( Maybe(Nothing, Just), catMaybes, fromMaybe, mapMaybe )
144−import Data.Monoid ( (<>), mconcat )
145import Data.Set ( Set )
144import Data.Set ( Set )
146import Language.Haskell.TH
145import Language.Haskell.TH
147#if MIN_VERSION_template_haskell(2,8,0)
146#if MIN_VERSION_template_haskell(2,8,0)
@@ -581,7 +580,7 @@ isMaybe (_, _, (_, _, AppT (ConT t) _)) = t == ''Maybe
581isMaybe _ = False
580isMaybe _ = False
582
581
583(<^>) :: ExpQ -> ExpQ -> ExpQ
582(<^>) :: ExpQ -> ExpQ -> ExpQ
584−(<^>) a b = infixApp a [|(<>)|] b
583+(<^>) a b = infixApp a [|(E.><)|] b
585infixr 6 <^>
584infixr 6 <^>
586
585
587(<:>) :: ExpQ -> ExpQ -> ExpQ
586(<:>) :: ExpQ -> ExpQ -> ExpQ
@@ -660,10 +659,10 @@ argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecord
660 (argTys, tvMap) <- reifyConTys jc tes conName
659 (argTys, tvMap) <- reifyConTys jc tes conName
661 let exp = object objBody
660 let exp = object objBody
662
661
663− objBody = [|mconcat|] `appE`
662+ objBody = [|E.econcat|] `appE`
664 ([|intersperse E.comma|] `appE` pairs)
663 ([|intersperse E.comma|] `appE` pairs)
665 pairs | omitNothingFields opts = infixApp maybeFields
664 pairs | omitNothingFields opts = infixApp maybeFields
666− [|(<>)|]
665+ [|(++)|]
667 restFields
666 restFields
668 | otherwise = listE (map toPair argCons)
667 | otherwise = listE (map toPair argCons)
669
668
@@ -680,7 +679,7 @@ argsToEncoding jc tes opts multiCons (RecC conName ts) = case (unwrapUnaryRecord
680 (infixApp
679 (infixApp
681 (infixE
680 (infixE
682 (Just $ toFieldName field <^> [|E.colon|])
681 (Just $ toFieldName field <^> [|E.colon|])
683− [|(<>)|]
682+ [|(E.><)|]
684 Nothing)
683 Nothing)
685 [|(.)|]
684 [|(.)|]
686 (dispatchToEncoding jc conName tvMap argTy))
685 (dispatchToEncoding jc conName tvMap argTy))
Data/Aeson/Text.hsnew file+97
@@ -0,0 +1,97 @@
1+{-# LANGUAGE BangPatterns, OverloadedStrings #-}
2+-- |
3+-- Module: Data.Aeson.Text
4+-- Copyright: (c) 2012-2016 Bryan O'Sullivan
5+-- (c) 2011 MailRank, Inc.
6+-- License: BSD3
7+-- Maintainer: Bryan O'Sullivan <bos@serpentine.com>
8+-- Stability: experimental
9+-- Portability: portable
10+--
11+-- Most frequently, you'll probably want to encode straight to UTF-8
12+-- (the standard JSON encoding) using 'encode'.
13+--
14+-- You can use the conversions to 'Builder's when embedding JSON messages as
15+-- parts of a protocol.
16+module Data.Aeson.Text
17+ ( encodeToLazyText
18+ , encodeToTextBuilder
19+ ) where
20+
21+import Data.Aeson.Types (Value(..), ToJSON(..))
22+import Data.Aeson.Encoding (encodingToLazyByteString)
23+import Data.Monoid ((<>))
24+import Data.Scientific (FPFormat(..), Scientific, base10Exponent)
25+import Data.Text.Lazy.Builder
26+import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)
27+
28+import Numeric (showHex)
29+import qualified Data.HashMap.Strict as H
30+import qualified Data.Text as T
31+import qualified Data.Text.Lazy as LT
32+import qualified Data.Text.Lazy.Encoding as LT
33+import qualified Data.Vector as V
34+
35+-- | Encode a JSON 'Value' to a "Data.Text.Lazy"
36+--
37+-- /Note:/ uses 'toEncoding'
38+encodeToLazyText :: ToJSON a => a -> LT.Text
39+encodeToLazyText = LT.decodeUtf8 . encodingToLazyByteString . toEncoding
40+
41+-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be
42+-- embedded efficiently in a text-based protocol.
43+--
44+-- If you are going to immediately encode straight to a
45+-- 'L.ByteString', it is more efficient to use 'encodeToBuilder'
46+-- instead.
47+--
48+-- /Note:/ Uses 'toJSON'
49+encodeToTextBuilder :: ToJSON a => a -> Builder
50+encodeToTextBuilder =
51+ go . toJSON
52+ where
53+ go Null = {-# SCC "go/Null" #-} "null"
54+ go (Bool b) = {-# SCC "go/Bool" #-} if b then "true" else "false"
55+ go (Number s) = {-# SCC "go/Number" #-} fromScientific s
56+ go (String s) = {-# SCC "go/String" #-} string s
57+ go (Array v)
58+ | V.null v = {-# SCC "go/Array" #-} "[]"
59+ | otherwise = {-# SCC "go/Array" #-}
60+ singleton '[' <>
61+ go (V.unsafeHead v) <>
62+ V.foldr f (singleton ']') (V.unsafeTail v)
63+ where f a z = singleton ',' <> go a <> z
64+ go (Object m) = {-# SCC "go/Object" #-}
65+ case H.toList m of
66+ (x:xs) -> singleton '{' <> one x <> foldr f (singleton '}') xs
67+ _ -> "{}"
68+ where f a z = singleton ',' <> one a <> z
69+ one (k,v) = string k <> singleton ':' <> go v
70+
71+string :: T.Text -> Builder
72+string s = {-# SCC "string" #-} singleton '"' <> quote s <> singleton '"'
73+ where
74+ quote q = case T.uncons t of
75+ Nothing -> fromText h
76+ Just (!c,t') -> fromText h <> escape c <> quote t'
77+ where (h,t) = {-# SCC "break" #-} T.break isEscape q
78+ isEscape c = c == '\"' ||
79+ c == '\\' ||
80+ c < '\x20'
81+ escape '\"' = "\\\""
82+ escape '\\' = "\\\\"
83+ escape '\n' = "\\n"
84+ escape '\r' = "\\r"
85+ escape '\t' = "\\t"
86+
87+ escape c
88+ | c < '\x20' = fromString $ "\\u" ++ replicate (4 - length h) '0' ++ h
89+ | otherwise = singleton c
90+ where h = showHex (fromEnum c) ""
91+
92+fromScientific :: Scientific -> Builder
93+fromScientific s = formatScientificBuilder format prec s
94+ where
95+ (format, prec)
96+ | base10Exponent s < 0 = (Generic, Nothing)
97+ | otherwise = (Fixed, Just 0)
Data/Aeson/Types.hs+3
@@ -40,10 +40,13 @@ module Data.Aeson.Types
40 -- ** Keys for maps
40 -- ** Keys for maps
41 , ToJSONKey(..)
41 , ToJSONKey(..)
42 , ToJSONKeyFunction(..)
42 , ToJSONKeyFunction(..)
43+ , toJSONKeyText
44+ , contramapToJSONKeyFunction
43 , FromJSONKey(..)
45 , FromJSONKey(..)
44 , FromJSONKeyFunction(..)
46 , FromJSONKeyFunction(..)
45 , fromJSONKeyCoerce
47 , fromJSONKeyCoerce
46 , coerceFromJSONKeyFunction
48 , coerceFromJSONKeyFunction
49+ , mapFromJSONKeyFunction
47
50
48 -- ** Liftings to unary and binary type constructors
51 -- ** Liftings to unary and binary type constructors
49 , FromJSON1(..)
52 , FromJSON1(..)
Data/Aeson/Types/Class.hs+1
@@ -51,6 +51,7 @@ module Data.Aeson.Types.Class
51 -- * Classes and types for map keys
51 -- * Classes and types for map keys
52 , ToJSONKey(..)
52 , ToJSONKey(..)
53 , ToJSONKeyFunction(..)
53 , ToJSONKeyFunction(..)
54+ , toJSONKeyText
54 , contramapToJSONKeyFunction
55 , contramapToJSONKeyFunction
55 , FromJSONKey(..)
56 , FromJSONKey(..)
56 , FromJSONKeyFunction(..)
57 , FromJSONKeyFunction(..)
Data/Aeson/Types/FromJSON.hs+81−24
@@ -69,7 +69,7 @@ module Data.Aeson.Types.FromJSON (
69import Prelude ()
69import Prelude ()
70import Prelude.Compat hiding (foldr)
70import Prelude.Compat hiding (foldr)
71
71
72−import Data.Aeson.Functions (mapKey)
72+import Data.Aeson.Internal.Functions (mapKey)
73import Data.Aeson.Types.Generic
73import Data.Aeson.Types.Generic
74import Data.Aeson.Types.Internal
74import Data.Aeson.Types.Internal
75
75
@@ -82,6 +82,7 @@ import Control.Monad ((<=<))
82import Data.Attoparsec.Number (Number (..))
82import Data.Attoparsec.Number (Number (..))
83import Data.Bits (unsafeShiftR)
83import Data.Bits (unsafeShiftR)
84import Data.Fixed (Fixed, HasResolution)
84import Data.Fixed (Fixed, HasResolution)
85+import Data.Functor.Compose (Compose (..))
85import Data.Functor.Identity (Identity (..))
86import Data.Functor.Identity (Identity (..))
86import Data.Hashable (Hashable (..))
87import Data.Hashable (Hashable (..))
87import Data.Int (Int16, Int32, Int64, Int8)
88import Data.Int (Int16, Int32, Int64, Int8)
@@ -127,9 +128,8 @@ import qualified Data.Vector.Unboxed as VU
127
128
128import Unsafe.Coerce (unsafeCoerce)
129import Unsafe.Coerce (unsafeCoerce)
129
130
130−-- Coercible derivations aren't as powerful on GHC 7.8, though supported.
131#ifndef HAS_COERCIBLE
131#ifndef HAS_COERCIBLE
132−#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 709)
132+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)
133#endif
133#endif
134
134
135#if HAS_COERCIBLE
135#if HAS_COERCIBLE
@@ -333,6 +333,7 @@ class FromJSONKey a where
333 fromJSONKey :: FromJSONKeyFunction a
333 fromJSONKey :: FromJSONKeyFunction a
334 default fromJSONKey :: FromJSON a => FromJSONKeyFunction a
334 default fromJSONKey :: FromJSON a => FromJSONKeyFunction a
335 fromJSONKey = FromJSONKeyValue parseJSON
335 fromJSONKey = FromJSONKeyValue parseJSON
336+
336 -- | This is similar in spirit to the 'readList' method of 'Read'.
337 -- | This is similar in spirit to the 'readList' method of 'Read'.
337 -- It makes it possible to give 'String' keys special treatment
338 -- It makes it possible to give 'String' keys special treatment
338 -- without using @OverlappingInstances@. End users should always
339 -- without using @OverlappingInstances@. End users should always
@@ -362,13 +363,13 @@ data CoerceText a where
362-- 'FromJSONKeyText', which is in turn more powerful than 'FromJSONKeyCoerce'.
363-- 'FromJSONKeyText', which is in turn more powerful than 'FromJSONKeyCoerce'.
363-- For performance reasons, these exist as three options instead of one.
364-- For performance reasons, these exist as three options instead of one.
364data FromJSONKeyFunction a
365data FromJSONKeyFunction a
365− = FromJSONKeyCoerce (CoerceText a)
366+ = FromJSONKeyCoerce !(CoerceText a)
366 -- ^ uses 'coerce' ('unsafeCoerce' in older GHCs)
367 -- ^ uses 'coerce' ('unsafeCoerce' in older GHCs)
367− | FromJSONKeyText (Text -> a)
368+ | FromJSONKeyText !(Text -> a)
368 -- ^ conversion from 'Text' that always succeeds
369 -- ^ conversion from 'Text' that always succeeds
369− | FromJSONKeyTextParser (Text -> Parser a)
370+ | FromJSONKeyTextParser !(Text -> Parser a)
370 -- ^ conversion from 'Text' that may fail
371 -- ^ conversion from 'Text' that may fail
371− | FromJSONKeyValue (Value -> Parser a)
372+ | FromJSONKeyValue !(Value -> Parser a)
372 -- ^ conversion for non-textual keys
373 -- ^ conversion for non-textual keys
373
374
374-- | Only law abiding up to interpretation
375-- | Only law abiding up to interpretation
@@ -383,6 +384,9 @@ instance Functor FromJSONKeyFunction where
383-- compatible with 'Text' i.e. hash values should be equal for wrapped values as well.
384-- compatible with 'Text' i.e. hash values should be equal for wrapped values as well.
384-- This property will always be maintained if the 'Hashable' and 'Eq' instances
385-- This property will always be maintained if the 'Hashable' and 'Eq' instances
385-- are derived with generalized newtype deriving.
386-- are derived with generalized newtype deriving.
387+-- compatible with 'Text' i.e. hash values be equal for wrapped values as well.
388+--
389+-- On pre GHC 7.8 this is unconstrainted function.
386fromJSONKeyCoerce ::
390fromJSONKeyCoerce ::
387#if HAS_COERCIBLE
391#if HAS_COERCIBLE
388 Coercible Text a =>
392 Coercible Text a =>
@@ -390,15 +394,22 @@ fromJSONKeyCoerce ::
390 FromJSONKeyFunction a
394 FromJSONKeyFunction a
391fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
395fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText
392
396
397+-- | Semantically the same as @coerceFromJSONKeyFunction = fmap coerce = coerce@.
398+--
399+-- See note on 'fromJSONKeyCoerce'.
393coerceFromJSONKeyFunction ::
400coerceFromJSONKeyFunction ::
394#if HAS_COERCIBLE
401#if HAS_COERCIBLE
395 Coercible a b =>
402 Coercible a b =>
396#endif
403#endif
397 FromJSONKeyFunction a -> FromJSONKeyFunction b
404 FromJSONKeyFunction a -> FromJSONKeyFunction b
405+#if HAS_COERCIBLE
406+coerceFromJSONKeyFunction = coerce
407+#else
398coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
408coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText
399coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
409coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)
400coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
410coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)
401coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
411coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)
412+#endif
402
413
403{-# RULES
414{-# RULES
404 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
415 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).
@@ -411,6 +422,7 @@ coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fma
411 #-}
422 #-}
412#endif
423#endif
413
424
425+-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.
414mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
426mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b
415mapFromJSONKeyFunction = fmap
427mapFromJSONKeyFunction = fmap
416
428
@@ -977,13 +989,6 @@ notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"
977-- base
989-- base
978-------------------------------------------------------------------------------
990-------------------------------------------------------------------------------
979
991
980−instance FromJSON1 Identity where
981− liftParseJSON p _ a = Identity <$> p a
982− {-# INLINE liftParseJSON #-}
983−
984−instance (FromJSON a) => FromJSON (Identity a) where
985− parseJSON = parseJSON1
986− {-# INLINE parseJSON #-}
987
992
988instance FromJSON2 Const where
993instance FromJSON2 Const where
989 liftParseJSON2 p _ _ _ = fmap Const . p
994 liftParseJSON2 p _ _ _ = fmap Const . p
@@ -1203,6 +1208,7 @@ instance FromJSON Word64 where
1203instance FromJSONKey Word64 where
1208instance FromJSONKey Word64 where
1204 fromJSONKey = FromJSONKeyTextParser parseIntegralText
1209 fromJSONKey = FromJSONKeyTextParser parseIntegralText
1205
1210
1211+
1206instance FromJSON Text where
1212instance FromJSON Text where
1207 parseJSON = withText "Text" pure
1213 parseJSON = withText "Text" pure
1208 {-# INLINE parseJSON #-}
1214 {-# INLINE parseJSON #-}
@@ -1210,17 +1216,28 @@ instance FromJSON Text where
1210instance FromJSONKey Text where
1216instance FromJSONKey Text where
1211 fromJSONKey = fromJSONKeyCoerce
1217 fromJSONKey = fromJSONKeyCoerce
1212
1218
1219+
1213instance FromJSON LT.Text where
1220instance FromJSON LT.Text where
1214 parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
1221 parseJSON = withText "Lazy Text" $ pure . LT.fromStrict
1215 {-# INLINE parseJSON #-}
1222 {-# INLINE parseJSON #-}
1216
1223
1224+instance FromJSONKey LT.Text where
1225+ fromJSONKey = FromJSONKeyText LT.fromStrict
1226+
1227+
1217instance FromJSON Version where
1228instance FromJSON Version where
1229+ parseJSON = withText "Version" parseVersionText
1218 {-# INLINE parseJSON #-}
1230 {-# INLINE parseJSON #-}
1231+
1232+instance FromJSONKey Version where
1233+ fromJSONKey = FromJSONKeyTextParser parseVersionText
1234+
1235+parseVersionText :: Text -> Parser Version
1219− parseJSON = withText "Version" $ go . readP_to_S parseVersion . unpack
1236+parseVersionText = go . readP_to_S parseVersion . unpack
1220− where
1237+ where
1221− go [(v,[])] = return v
1238+ go [(v,[])] = return v
1222− go (_ : xs) = go xs
1239+ go (_ : xs) = go xs
1223− go _ = fail $ "could not parse Version"
1240+ go _ = fail $ "could not parse Version"
1224
1241
1225-------------------------------------------------------------------------------
1242-------------------------------------------------------------------------------
1226-- semigroups NonEmpty
1243-- semigroups NonEmpty
@@ -1260,6 +1277,49 @@ instance (FromJSON a) => FromJSON (DList.DList a) where
1260 parseJSON = parseJSON1
1277 parseJSON = parseJSON1
1261 {-# INLINE parseJSON #-}
1278 {-# INLINE parseJSON #-}
1262
1279
1280+-------------------------------------------------------------------------------
1281+-- tranformers - Functors
1282+-------------------------------------------------------------------------------
1283+
1284+instance FromJSON1 Identity where
1285+ liftParseJSON p _ a = Identity <$> p a
1286+ {-# INLINE liftParseJSON #-}
1287+
1288+ liftParseJSONList _ p a = fmap Identity <$> p a
1289+ {-# INLINE liftParseJSONList #-}
1290+
1291+instance (FromJSON a) => FromJSON (Identity a) where
1292+ parseJSON = parseJSON1
1293+ {-# INLINE parseJSON #-}
1294+
1295+ parseJSONList = liftParseJSONList parseJSON parseJSONList
1296+ {-# INLINE parseJSONList #-}
1297+
1298+instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where
1299+ fromJSONKey = coerceFromJSONKeyFunction (fromJSONKey :: FromJSONKeyFunction a)
1300+ fromJSONKeyList = coerceFromJSONKeyFunction (fromJSONKeyList :: FromJSONKeyFunction [a])
1301+
1302+
1303+instance (FromJSON1 f, FromJSON1 g) => FromJSON1 (Compose f g) where
1304+ liftParseJSON p pl a = Compose <$> liftParseJSON g gl a
1305+ where
1306+ g = liftParseJSON p pl
1307+ gl = liftParseJSONList p pl
1308+ {-# INLINE liftParseJSON #-}
1309+
1310+ liftParseJSONList p pl a = map Compose <$> liftParseJSONList g gl a
1311+ where
1312+ g = liftParseJSON p pl
1313+ gl = liftParseJSONList p pl
1314+ {-# INLINE liftParseJSONList #-}
1315+
1316+instance (FromJSON1 f, FromJSON1 g, FromJSON a) => FromJSON (Compose f g a) where
1317+ parseJSON = parseJSON1
1318+ {-# INLINE parseJSON #-}
1319+
1320+ parseJSONList = liftParseJSONList parseJSON parseJSONList
1321+ {-# INLINE parseJSONList #-}
1322+
1263-------------------------------------------------------------------------------
1323-------------------------------------------------------------------------------
1264-- containers
1324-- containers
1265-------------------------------------------------------------------------------
1325-------------------------------------------------------------------------------
@@ -1304,7 +1364,7 @@ instance (FromJSONKey k, Ord k) => FromJSON1 (M.Map k) where
1304 FromJSONKeyText f -> withObject "Map k v" $
1364 FromJSONKeyText f -> withObject "Map k v" $
1305 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1365 fmap (H.foldrWithKey (M.insert . f) M.empty) . H.traverseWithKey (\k v -> p v <?> Key k)
1306 FromJSONKeyTextParser f -> withObject "Map k v" $
1366 FromJSONKeyTextParser f -> withObject "Map k v" $
1307− H.foldrWithKey (\k v m -> M.insert <$> f k <*> (p v <?> Key k) <*> m) (pure M.empty)
1367+ H.foldrWithKey (\k v m -> M.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure M.empty)
1308 FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1368 FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1309 M.fromList <$> (Tr.sequence .
1369 M.fromList <$> (Tr.sequence .
1310 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
1370 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
@@ -1372,7 +1432,7 @@ instance (FromJSONKey k, Eq k, Hashable k) => FromJSON1 (H.HashMap k) where
1372 FromJSONKeyText f -> withObject "HashMap k v" $
1432 FromJSONKeyText f -> withObject "HashMap k v" $
1373 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1433 fmap (mapKey f) . H.traverseWithKey (\k v -> p v <?> Key k)
1374 FromJSONKeyTextParser f -> withObject "HashMap k v" $
1434 FromJSONKeyTextParser f -> withObject "HashMap k v" $
1375− H.foldrWithKey (\k v m -> H.insert <$> f k <*> (p v <?> Key k) <*> m) (pure H.empty)
1435+ H.foldrWithKey (\k v m -> H.insert <$> f k <?> Key k <*> p v <?> Key k <*> m) (pure H.empty)
1376 FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1436 FromJSONKeyValue f -> withArray "Map k v" $ \arr ->
1377 H.fromList <$> (Tr.sequence .
1437 H.fromList <$> (Tr.sequence .
1378 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
1438 zipWith (parseIndexedJSONPair f p) [0..] . V.toList $ arr)
@@ -1518,9 +1578,6 @@ instance FromJSONKey Char where
1518instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
1578instance (FromJSONKey a, FromJSON a) => FromJSONKey [a] where
1519 fromJSONKey = fromJSONKeyList
1579 fromJSONKey = fromJSONKeyList
1520
1580
1521−instance (FromJSONKey a, FromJSON a) => FromJSONKey (Identity a) where
1522− fromJSONKey = mapFromJSONKeyFunction Identity fromJSONKey
1523−
1524-------------------------------------------------------------------------------
1581-------------------------------------------------------------------------------
1525-- Tuple instances, see tuple-instances-from.hs
1582-- Tuple instances, see tuple-instances-from.hs
1526-------------------------------------------------------------------------------
1583-------------------------------------------------------------------------------
Data/Aeson/Types/Generic.hs+3
@@ -25,6 +25,9 @@
25
25
26module Data.Aeson.Types.Generic where
26module Data.Aeson.Types.Generic where
27
27
28+import Prelude ()
29+import Prelude.Compat
30+
28import GHC.Generics
31import GHC.Generics
29import Data.Proxy (Proxy (..))
32import Data.Proxy (Proxy (..))
30
33
Data/Aeson/Types/Internal.hs+4−7
@@ -60,8 +60,11 @@ module Data.Aeson.Types.Internal
60 , DotNetTime(..)
60 , DotNetTime(..)
61 ) where
61 ) where
62
62
63+import Prelude ()
64+import Prelude.Compat
65+
63import Control.Arrow (first)
66import Control.Arrow (first)
64−import Control.Applicative
67+import Control.Applicative (Alternative(..))
65import Control.DeepSeq (NFData(..))
68import Control.DeepSeq (NFData(..))
66import Control.Monad (MonadPlus(..), ap)
69import Control.Monad (MonadPlus(..), ap)
67import qualified Control.Monad.Fail as Fail
70import qualified Control.Monad.Fail as Fail
@@ -83,12 +86,6 @@ import qualified Data.Scientific as S
83import qualified Data.Vector as V
86import qualified Data.Vector as V
84import qualified Language.Haskell.TH.Syntax as TH
87import qualified Language.Haskell.TH.Syntax as TH
85
88
86−#if !MIN_VERSION_base(4,8,0)
87−import Data.Foldable (Foldable(..))
88−import Data.Monoid (Monoid(..))
89−import Data.Traversable (Traversable(..))
90−#endif
91−
92#if !MIN_VERSION_unordered_containers(0,2,6)
89#if !MIN_VERSION_unordered_containers(0,2,6)
93import Data.List (sort)
90import Data.List (sort)
94#endif
91#endif
Data/Aeson/Types/ToJSON.hs+186−118
@@ -43,6 +43,7 @@ module Data.Aeson.Types.ToJSON (
43 -- * Classes and types for map keys
43 -- * Classes and types for map keys
44 , ToJSONKey(..)
44 , ToJSONKey(..)
45 , ToJSONKeyFunction(..)
45 , ToJSONKeyFunction(..)
46+ , toJSONKeyText
46 , contramapToJSONKeyFunction
47 , contramapToJSONKeyFunction
47 -- * Object key-value pairs
48 -- * Object key-value pairs
48 , KeyValue(..)
49 , KeyValue(..)
@@ -55,9 +56,9 @@ module Data.Aeson.Types.ToJSON (
55import Prelude ()
56import Prelude ()
56import Prelude.Compat
57import Prelude.Compat
57
58
58−import Data.Aeson.Encoding.Internal (Encoding (..), Series, dict, emptyArray_,
59+import Data.Aeson.Encoding.Internal (Encoding, Encoding', Series, dict,
59− tuple, (>*<))
60+ emptyArray_, tuple, (>*<), (><))
60−import Data.Aeson.Functions (mapHashKeyVal, mapKeyVal)
61+import Data.Aeson.Internal.Functions (mapHashKeyVal, mapKeyVal)
61import Data.Aeson.Types.Generic
62import Data.Aeson.Types.Generic
62import Data.Aeson.Types.Internal
63import Data.Aeson.Types.Internal
63
64
@@ -71,6 +72,7 @@ import Data.Bits (unsafeShiftR)
71import Data.DList (DList)
72import Data.DList (DList)
72import Data.Fixed (Fixed, HasResolution)
73import Data.Fixed (Fixed, HasResolution)
73import Data.Foldable (toList)
74import Data.Foldable (toList)
75+import Data.Functor.Compose (Compose (..))
74import Data.Functor.Identity (Identity (..))
76import Data.Functor.Identity (Identity (..))
75import Data.Int (Int16, Int32, Int64, Int8)
77import Data.Int (Int16, Int32, Int64, Int8)
76import Data.List (intersperse)
78import Data.List (intersperse)
@@ -92,35 +94,30 @@ import Foreign.Storable (Storable)
92import GHC.Generics
94import GHC.Generics
93import Numeric.Natural (Natural)
95import Numeric.Natural (Natural)
94
96
95−import qualified Data.ByteString.Builder as B (toLazyByteString)
97+import qualified Data.ByteString.Lazy as L
96−import qualified Data.ByteString.Lazy as L
97−import qualified Data.DList as DList
98+import qualified Data.DList as DList
98−import qualified Data.HashMap.Strict as H
99+import qualified Data.HashMap.Strict as H
99−import qualified Data.HashSet as HashSet
100+import qualified Data.HashSet as HashSet
100−import qualified Data.IntMap as IntMap
101+import qualified Data.IntMap as IntMap
101−import qualified Data.IntSet as IntSet
102+import qualified Data.IntSet as IntSet
102−import qualified Data.List.NonEmpty as NE
103+import qualified Data.List.NonEmpty as NE
103−import qualified Data.Map as M
104+import qualified Data.Map as M
104−import qualified Data.Scientific as Scientific
105+import qualified Data.Scientific as Scientific
105−import qualified Data.Sequence as Seq
106+import qualified Data.Sequence as Seq
106−import qualified Data.Set as Set
107+import qualified Data.Set as Set
107−import qualified Data.Text as T
108+import qualified Data.Text as T
108−import qualified Data.Text.Encoding as T
109+import qualified Data.Text.Encoding as T
109−import qualified Data.Text.Lazy as LT
110+import qualified Data.Text.Lazy as LT
110−import qualified Data.Tree as Tree
111+import qualified Data.Tree as Tree
111−import qualified Data.Vector as V
112+import qualified Data.Vector as V
112−import qualified Data.Vector.Generic as VG
113+import qualified Data.Vector.Generic as VG
113−import qualified Data.Vector.Mutable as VM
114+import qualified Data.Vector.Mutable as VM
114−import qualified Data.Vector.Primitive as VP
115+import qualified Data.Vector.Primitive as VP
115−import qualified Data.Vector.Storable as VS
116+import qualified Data.Vector.Storable as VS
116−import qualified Data.Vector.Unboxed as VU
117+import qualified Data.Vector.Unboxed as VU
117
118
118toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
119toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value
119−toJSONPair keySerialiser valSerializer (a, b) = Array $ V.create $ do
120+toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)
120− mv <- VM.unsafeNew 2
121− VM.unsafeWrite mv 0 (keySerialiser a)
122− VM.unsafeWrite mv 1 (valSerializer b)
123− return mv
124{-# INLINE toJSONPair #-}
121{-# INLINE toJSONPair #-}
125
122
126realFloatToJSON :: RealFloat a => a -> Value
123realFloatToJSON :: RealFloat a => a -> Value
@@ -309,7 +306,7 @@ instance KeyValue Pair where
309
306
310-- | Typeclass for types that can be used as the key of a map-like container
307-- | Typeclass for types that can be used as the key of a map-like container
311-- (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'
308-- (like 'Map' or 'HashMap'). For example, since 'Text' has a 'ToJSONKey'
312−-- instance and 'Char' has a 'ToJSON' instance, we can encode a value of
309+-- instance and 'Char' has a 'ToJSON' instance, we can encode a value of
313-- type 'Map' 'Text' 'Char':
310-- type 'Map' 'Text' 'Char':
314--
311--
315-- >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]
312-- >>> LBC8.putStrLn $ encode $ Map.fromList [("foo" :: Text, 'a')]
@@ -355,16 +352,16 @@ instance KeyValue Pair where
355-- >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]
352-- >>> let m = Map.fromList [(Foo 4 "bar",'a'),(Foo 6 "arg",'b')]
356-- >>> LBC8.putStrLn $ encode m
353-- >>> LBC8.putStrLn $ encode m
357-- [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]
354-- [[{"fooName":"bar","fooAge":4},"a"],[{"fooName":"arg","fooAge":6},"b"]]
358−--
355+--
359-- The next case to consider is if we have a type that is a
356-- The next case to consider is if we have a type that is a
360-- newtype wrapper around 'Text'. The recommended approach is to use
357-- newtype wrapper around 'Text'. The recommended approach is to use
361-- generalized newtype deriving:
358-- generalized newtype deriving:
362--
359--
363-- > newtype RecordId = RecordId { getRecordId :: Text}
360-- > newtype RecordId = RecordId { getRecordId :: Text}
364-- > deriving (Eq,Ord,ToJSONKey)
361-- > deriving (Eq,Ord,ToJSONKey)
365−--
362+--
366-- Then we may write:
363-- Then we may write:
367−--
364+--
368-- >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]
365-- >>> LBC8.putStrLn $ encode $ Map.fromList [(RecordId "abc",'a')]
369-- {"abc":"a"}
366-- {"abc":"a"}
370--
367--
@@ -382,7 +379,7 @@ instance KeyValue Pair where
382-- > instance ToJSONKey Color where
379-- > instance ToJSONKey Color where
383-- > toJSONKey = ToJSONKeyText f g
380-- > toJSONKey = ToJSONKeyText f g
384-- > where f = Text.pack . show
381-- > where f = Text.pack . show
385−-- > g = text . Text.pack . show
382+-- > g = text . Text.pack . show
386-- > -- text function is from Data.Aeson.Encoding
383-- > -- text function is from Data.Aeson.Encoding
387--
384--
388-- The situation of needing to turning function @a -> Text@ into
385-- The situation of needing to turning function @a -> Text@ into
@@ -391,7 +388,7 @@ instance KeyValue Pair where
391--
388--
392-- > instance ToJSONKey Color where
389-- > instance ToJSONKey Color where
393-- > toJSONKey = toJSONKeyText (Text.pack . show)
390-- > toJSONKey = toJSONKeyText (Text.pack . show)
394−--
391+--
395-- The performance of the above instance can be improved by
392-- The performance of the above instance can be improved by
396-- not using 'String' as an intermediate step when converting to
393-- not using 'String' as an intermediate step when converting to
397-- 'Text'. One option for improving performance would be to use
394-- 'Text'. One option for improving performance would be to use
@@ -400,7 +397,7 @@ instance KeyValue Pair where
400-- builder) is generated by encoding the 'Text' to a 'ByteString',
397-- builder) is generated by encoding the 'Text' to a 'ByteString',
401-- an intermediate step that could be avoided. The fastest possible
398-- an intermediate step that could be avoided. The fastest possible
402-- implementation would be:
399-- implementation would be:
403−--
400+--
404-- > -- Assuming that OverloadedStrings is enabled
401-- > -- Assuming that OverloadedStrings is enabled
405-- > instance ToJSONKey Color where
402-- > instance ToJSONKey Color where
406-- > toJSONKey = ToJSONKeyText f g
403-- > toJSONKey = ToJSONKeyText f g
@@ -417,23 +414,45 @@ class ToJSONKey a where
417 -- | Strategy for rendering the key for a map-like container.
414 -- | Strategy for rendering the key for a map-like container.
418 toJSONKey :: ToJSONKeyFunction a
415 toJSONKey :: ToJSONKeyFunction a
419 default toJSONKey :: ToJSON a => ToJSONKeyFunction a
416 default toJSONKey :: ToJSON a => ToJSONKeyFunction a
420− toJSONKey = ToJSONKeyValue (toJSON, toEncoding)
417+ toJSONKey = ToJSONKeyValue toJSON toEncoding
418+
421 -- | This is similar in spirit to the 'showsList' method of 'Show'.
419 -- | This is similar in spirit to the 'showsList' method of 'Show'.
422 -- It makes it possible to give 'String' keys special treatment
420 -- It makes it possible to give 'String' keys special treatment
423 -- without using @OverlappingInstances@. End users should always
421 -- without using @OverlappingInstances@. End users should always
424 -- be able to use the default implementation of this method.
422 -- be able to use the default implementation of this method.
425 toJSONKeyList :: ToJSONKeyFunction [a]
423 toJSONKeyList :: ToJSONKeyFunction [a]
426 default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]
424 default toJSONKeyList :: ToJSON a => ToJSONKeyFunction [a]
427− toJSONKeyList = ToJSONKeyValue (toJSON, toEncoding)
425+ toJSONKeyList = ToJSONKeyValue toJSON toEncoding
428
426
429data ToJSONKeyFunction a
427data ToJSONKeyFunction a
428+ = ToJSONKeyText !(a -> Text) !(a -> Encoding' Text)
430− = ToJSONKeyText (a -> Text, a -> Encoding) -- ^ key is encoded to string, produces object
429+ -- ^ key is encoded to string, produces object
430+ | ToJSONKeyValue !(a -> Value) !(a -> Encoding)
431− | ToJSONKeyValue (a -> Value, a -> Encoding) -- ^ key is encoded to value, produces array
431+ -- ^ key is encoded to value, produces array
432
432
433+-- | Helper for creating textual keys.
434+--
435+-- @
436+-- instance 'ToJSONKey' MyKey where
437+-- 'toJSONKey' = 'toJSONKeyText' myKeyToText
438+-- where
439+-- myKeyToText = Text.pack . show -- or showt from text-show
440+-- @
441+toJSONKeyText :: (a -> Text) -> ToJSONKeyFunction a
442+toJSONKeyText f = ToJSONKeyText f (E.text . f)
443+
444+-- | TODO: should this be exported?
445+toJSONKeyTextEnc :: (a -> Encoding' Text) -> ToJSONKeyFunction a
446+toJSONKeyTextEnc e = ToJSONKeyText tot e
447+ where
448+ -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
449+ tot = T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . E.encodingToLazyByteString . e
450+
451+-- | Contravariant map, as 'ToJSONKeyFunction' is a contravariant functor.
433contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
452contramapToJSONKeyFunction :: (b -> a) -> ToJSONKeyFunction a -> ToJSONKeyFunction b
434contramapToJSONKeyFunction h x = case x of
453contramapToJSONKeyFunction h x = case x of
435− ToJSONKeyText (f,g) -> ToJSONKeyText (f . h, g . h)
454+ ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)
436− ToJSONKeyValue (f,g) -> ToJSONKeyValue (f . h, g . h)
455+ ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)
437
456
438-------------------------------------------------------------------------------
457-------------------------------------------------------------------------------
439-- Lifings of FromJSON and ToJSON to unary and binary type constructors
458-- Lifings of FromJSON and ToJSON to unary and binary type constructors
@@ -676,7 +695,7 @@ instance ( AllNullary (a :+: b) allNullary
676 -- 'allNullaryToStringTag' option is set they are encoded to
695 -- 'allNullaryToStringTag' option is set they are encoded to
677 -- strings. This distinction is made by 'sumToEncoding':
696 -- strings. This distinction is made by 'sumToEncoding':
678 gToEncoding opts pa te tel
697 gToEncoding opts pa te tel
679− = (unTagged :: Tagged allNullary Encoding -> Encoding)
698+ = (unTagged :: Tagged allNullary (Encoding) -> Encoding)
680 . sumToEncoding opts pa te tel
699 . sumToEncoding opts pa te tel
681
700
682instance (ToJSON1 f, GToEncoding One g) => GToEncoding One (f :.: g) where
701instance (ToJSON1 f, GToEncoding One g) => GToEncoding One (f :.: g) where
@@ -728,7 +747,7 @@ nonAllNullarySumToJSON opts pa tj tjl =
728class SumToEncoding arity f allNullary where
747class SumToEncoding arity f allNullary where
729 sumToEncoding :: Options -> Proxy arity
748 sumToEncoding :: Options -> Proxy arity
730 -> (a -> Encoding) -> ([a] -> Encoding)
749 -> (a -> Encoding) -> ([a] -> Encoding)
731− -> f a -> Tagged allNullary Encoding
750+ -> f a -> Tagged allNullary (Encoding)
732
751
733instance ( GetConName f
752instance ( GetConName f
734 , TaggedObjectEnc arity f
753 , TaggedObjectEnc arity f
@@ -822,29 +841,28 @@ instance ( IsRecord a isRecord
822 , Constructor c
841 , Constructor c
823 ) => TaggedObjectEnc arity (C1 c a) where
842 ) => TaggedObjectEnc arity (C1 c a) where
824 taggedObjectEnc opts pa tagFieldName contentsFieldName te tel v =
843 taggedObjectEnc opts pa tagFieldName contentsFieldName te tel v =
825− E.openCurly <>
844+ E.wrapObject $
826− (toEncoding tagFieldName <>
845+ (E.string tagFieldName ><
827− E.colon <>
846+ E.colon ><
828− toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))) <>
847+ toEncoding (constructorTagModifier opts (conName (undefined :: t c a p)))) ><
829− ((unTagged :: Tagged isRecord Encoding -> Encoding) .
848+ ((unTagged :: Tagged isRecord (Encoding) -> Encoding) .
830− taggedObjectEnc' opts pa contentsFieldName te tel . unM1 $ v) <>
849+ taggedObjectEnc' opts pa contentsFieldName te tel . unM1 $ v)
831− E.closeCurly
832
850
833class TaggedObjectEnc' arity f isRecord where
851class TaggedObjectEnc' arity f isRecord where
834 taggedObjectEnc' :: Options -> Proxy arity
852 taggedObjectEnc' :: Options -> Proxy arity
835 -> String -> (a -> Encoding) -> ([a] -> Encoding)
853 -> String -> (a -> Encoding) -> ([a] -> Encoding)
836− -> f a -> Tagged isRecord Encoding
854+ -> f a -> Tagged isRecord (Encoding)
837
855
838instance OVERLAPPING_ TaggedObjectEnc' arity U1 False where
856instance OVERLAPPING_ TaggedObjectEnc' arity U1 False where
839− taggedObjectEnc' _ _ _ _ _ _ = Tagged mempty
857+ taggedObjectEnc' _ _ _ _ _ _ = Tagged E.empty
840
858
841instance (RecordToEncoding arity f) => TaggedObjectEnc' arity f True where
859instance (RecordToEncoding arity f) => TaggedObjectEnc' arity f True where
842− taggedObjectEnc' opts pa _ te tel = Tagged . (E.comma <>) . fst
860+ taggedObjectEnc' opts pa _ te tel = Tagged . (E.comma ><) . fst
843 . recordToEncoding opts pa te tel
861 . recordToEncoding opts pa te tel
844
862
845instance (GToEncoding arity f) => TaggedObjectEnc' arity f False where
863instance (GToEncoding arity f) => TaggedObjectEnc' arity f False where
846 taggedObjectEnc' opts pa contentsFieldName te tel =
864 taggedObjectEnc' opts pa contentsFieldName te tel =
847− Tagged . (\z -> E.comma <> toEncoding contentsFieldName <> E.colon <> z) .
865+ Tagged . (\z -> E.comma >< toEncoding contentsFieldName >< E.colon >< z) .
848 gToEncoding opts pa te tel
866 gToEncoding opts pa te tel
849
867
850--------------------------------------------------------------------------------
868--------------------------------------------------------------------------------
@@ -946,13 +964,13 @@ class ConsToEncoding' arity f isRecord where
946 consToEncoding' :: Options -> Proxy arity
964 consToEncoding' :: Options -> Proxy arity
947 -> Bool -- ^ Are we a record with one field?
965 -> Bool -- ^ Are we a record with one field?
948 -> (a -> Encoding) -> ([a] -> Encoding)
966 -> (a -> Encoding) -> ([a] -> Encoding)
949− -> f a -> Tagged isRecord Encoding
967+ -> f a -> Tagged isRecord (Encoding)
950
968
951instance ( IsRecord f isRecord
969instance ( IsRecord f isRecord
952 , ConsToEncoding' arity f isRecord
970 , ConsToEncoding' arity f isRecord
953 ) => ConsToEncoding arity f where
971 ) => ConsToEncoding arity f where
954 consToEncoding opts pa te tel =
972 consToEncoding opts pa te tel =
955− (unTagged :: Tagged isRecord Encoding -> Encoding)
973+ (unTagged :: Tagged isRecord (Encoding) -> (Encoding))
956 . consToEncoding' opts pa (isUnary (undefined :: f a)) te tel
974 . consToEncoding' opts pa (isUnary (undefined :: f a)) te tel
957
975
958instance (RecordToEncoding arity f) => ConsToEncoding' arity f True where
976instance (RecordToEncoding arity f) => ConsToEncoding' arity f True where
@@ -1003,39 +1021,40 @@ class RecordToEncoding arity f where
1003 -- of the field (without the key); 'Nothing' otherwise
1021 -- of the field (without the key); 'Nothing' otherwise
1004 recordToEncoding :: Options -> Proxy arity
1022 recordToEncoding :: Options -> Proxy arity
1005 -> (a -> Encoding) -> ([a] -> Encoding)
1023 -> (a -> Encoding) -> ([a] -> Encoding)
1006− -> f a -> (Encoding, Maybe Encoding)
1024+ -> f a -> (Encoding, Maybe (Encoding))
1007
1025
1008instance ( RecordToEncoding arity a
1026instance ( RecordToEncoding arity a
1009 , RecordToEncoding arity b
1027 , RecordToEncoding arity b
1010 ) => RecordToEncoding arity (a :*: b) where
1028 ) => RecordToEncoding arity (a :*: b) where
1011 recordToEncoding opts pa te tel (a :*: b) | omitNothingFields opts =
1029 recordToEncoding opts pa te tel (a :*: b) | omitNothingFields opts =
1012− (mconcat $ intersperse E.comma $
1030+ (E.econcat $ intersperse E.comma $
1013 filter (not . E.nullEncoding)
1031 filter (not . E.nullEncoding)
1014 [ fst (recordToEncoding opts pa te tel a)
1032 [ fst (recordToEncoding opts pa te tel a)
1015 , fst (recordToEncoding opts pa te tel b) ]
1033 , fst (recordToEncoding opts pa te tel b) ]
1016 , Nothing)
1034 , Nothing)
1017 recordToEncoding opts pa te tel (a :*: b) =
1035 recordToEncoding opts pa te tel (a :*: b) =
1018− (fst (recordToEncoding opts pa te tel a) <> E.comma <>
1036+ (fst (recordToEncoding opts pa te tel a) >< E.comma ><
1019 fst (recordToEncoding opts pa te tel b),
1037 fst (recordToEncoding opts pa te tel b),
1020 Nothing)
1038 Nothing)
1021
1039
1040+
1022instance (Selector s, GToEncoding arity a) => RecordToEncoding arity (S1 s a) where
1041instance (Selector s, GToEncoding arity a) => RecordToEncoding arity (S1 s a) where
1023 recordToEncoding = fieldToEncoding
1042 recordToEncoding = fieldToEncoding
1024
1043
1025instance OVERLAPPING_ (Selector s, ToJSON a) =>
1044instance OVERLAPPING_ (Selector s, ToJSON a) =>
1026 RecordToEncoding arity (S1 s (K1 i (Maybe a))) where
1045 RecordToEncoding arity (S1 s (K1 i (Maybe a))) where
1027 recordToEncoding opts _ _ _ (M1 k1) | omitNothingFields opts
1046 recordToEncoding opts _ _ _ (M1 k1) | omitNothingFields opts
1028− , K1 Nothing <- k1 = (mempty, Nothing)
1047+ , K1 Nothing <- k1 = (E.empty, Nothing)
1029 recordToEncoding opts pa te tel m1 = fieldToEncoding opts pa te tel m1
1048 recordToEncoding opts pa te tel m1 = fieldToEncoding opts pa te tel m1
1030
1049
1031fieldToEncoding :: (Selector s, GToEncoding arity a)
1050fieldToEncoding :: (Selector s, GToEncoding arity a)
1032 => Options -> Proxy arity
1051 => Options -> Proxy arity
1033 -> (p -> Encoding) -> ([p] -> Encoding)
1052 -> (p -> Encoding) -> ([p] -> Encoding)
1034− -> S1 s a p -> (Encoding, Maybe Encoding)
1053+ -> S1 s a p -> (Encoding, Maybe (Encoding))
1035fieldToEncoding opts pa te tel m1 =
1054fieldToEncoding opts pa te tel m1 =
1036 let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)
1055 let keyBuilder = toEncoding (fieldLabelModifier opts $ selName m1)
1037 valueBuilder = gToEncoding opts pa te tel (unM1 m1)
1056 valueBuilder = gToEncoding opts pa te tel (unM1 m1)
1038− in (keyBuilder <> E.colon <> valueBuilder, Just valueBuilder)
1057+ in (keyBuilder >< E.colon >< valueBuilder, Just valueBuilder)
1039
1058
1040--------------------------------------------------------------------------------
1059--------------------------------------------------------------------------------
1041
1060
@@ -1070,21 +1089,20 @@ instance OVERLAPPABLE_ (GToJSON arity a) => WriteProduct arity a where
1070class EncodeProduct arity f where
1089class EncodeProduct arity f where
1071 encodeProduct :: Options -> Proxy arity
1090 encodeProduct :: Options -> Proxy arity
1072 -> (a -> Encoding) -> ([a] -> Encoding)
1091 -> (a -> Encoding) -> ([a] -> Encoding)
1073− -> f a -> Encoding
1092+ -> f a -> Encoding' E.InArray
1074
1093
1075instance ( EncodeProduct arity a
1094instance ( EncodeProduct arity a
1076 , EncodeProduct arity b
1095 , EncodeProduct arity b
1077 ) => EncodeProduct arity (a :*: b) where
1096 ) => EncodeProduct arity (a :*: b) where
1078 encodeProduct opts pa te tel (a :*: b) | omitNothingFields opts =
1097 encodeProduct opts pa te tel (a :*: b) | omitNothingFields opts =
1079− mconcat $ intersperse E.comma $
1098+ E.econcat $ intersperse E.comma $
1080 filter (not . E.nullEncoding)
1099 filter (not . E.nullEncoding)
1081 [encodeProduct opts pa te tel a, encodeProduct opts pa te tel b]
1100 [encodeProduct opts pa te tel a, encodeProduct opts pa te tel b]
1082− encodeProduct opts pa te tel (a :*: b) = encodeProduct opts pa te tel a <>
1101+ encodeProduct opts pa te tel (a :*: b) = encodeProduct opts pa te tel a >*<
1083− E.comma <>
1084 encodeProduct opts pa te tel b
1102 encodeProduct opts pa te tel b
1085
1103
1086instance OVERLAPPABLE_ (GToEncoding arity a) => EncodeProduct arity a where
1104instance OVERLAPPABLE_ (GToEncoding arity a) => EncodeProduct arity a where
1087− encodeProduct opts = gToEncoding opts
1105+ encodeProduct opts pa te tel a = E.retagEncoding $ gToEncoding opts pa te tel a
1088
1106
1089--------------------------------------------------------------------------------
1107--------------------------------------------------------------------------------
1090
1108
@@ -1130,12 +1148,12 @@ instance ( GToEncoding arity a
1130 , Constructor c
1148 , Constructor c
1131 ) => ObjectWithSingleFieldEnc arity (C1 c a) where
1149 ) => ObjectWithSingleFieldEnc arity (C1 c a) where
1132 objectWithSingleFieldEnc opts pa te tel v =
1150 objectWithSingleFieldEnc opts pa te tel v =
1133− E.openCurly <>
1151+ E.openCurly ><
1134 toEncoding
1152 toEncoding
1135 (constructorTagModifier opts
1153 (constructorTagModifier opts
1136− (conName (undefined :: t c a p))) <>
1154+ (conName (undefined :: t c a p))) ><
1137− E.colon <>
1155+ E.colon ><
1138− gToEncoding opts pa te tel v <>
1156+ gToEncoding opts pa te tel v ><
1139 E.closeCurly
1157 E.closeCurly
1140
1158
1141-------------------------------------------------------------------------------
1159-------------------------------------------------------------------------------
@@ -1146,21 +1164,6 @@ instance ( GToEncoding arity a
1146-- base
1164-- base
1147-------------------------------------------------------------------------------
1165-------------------------------------------------------------------------------
1148
1166
1149−instance ToJSON1 Identity where
1150− liftToJSON t _ (Identity a) = t a
1151− {-# INLINE liftToJSON #-}
1152−
1153− liftToEncoding t _ (Identity a) = t a
1154− {-# INLINE liftToEncoding #-}
1155−
1156−instance (ToJSON a) => ToJSON (Identity a) where
1157− toJSON = toJSON1
1158− {-# INLINE toJSON #-}
1159−
1160− toEncoding = toEncoding1
1161− {-# INLINE toEncoding #-}
1162−
1163−
1164instance ToJSON2 Const where
1167instance ToJSON2 Const where
1165 liftToJSON2 t _ _ _ (Const x) = t x
1168 liftToJSON2 t _ _ _ (Const x) = t x
1166 {-# INLINE liftToJSON2 #-}
1169 {-# INLINE liftToJSON2 #-}
@@ -1237,10 +1240,7 @@ instance ToJSON Bool where
1237 {-# INLINE toEncoding #-}
1240 {-# INLINE toEncoding #-}
1238
1241
1239instance ToJSONKey Bool where
1242instance ToJSONKey Bool where
1240− toJSONKey = ToJSONKeyText
1241− ( (\x -> if x then "true" else "false")
1242− , (\x -> toEncoding $ if x then ("true" :: Text) else "false")
1243+ toJSONKey = toJSONKeyText $ \x -> if x then "true" else "false"
1243− )
1244
1244
1245
1245
1246instance ToJSON Ordering where
1246instance ToJSON Ordering where
@@ -1485,9 +1485,10 @@ instance ToJSON Text where
1485 {-# INLINE toEncoding #-}
1485 {-# INLINE toEncoding #-}
1486
1486
1487instance ToJSONKey Text where
1487instance ToJSONKey Text where
1488− toJSONKey = ToJSONKeyText (id, toEncoding)
1488+ toJSONKey = toJSONKeyText id
1489 {-# INLINE toJSONKey #-}
1489 {-# INLINE toJSONKey #-}
1490
1490
1491+
1491instance ToJSON LT.Text where
1492instance ToJSON LT.Text where
1492 toJSON = String . LT.toStrict
1493 toJSON = String . LT.toStrict
1493 {-# INLINE toJSON #-}
1494 {-# INLINE toJSON #-}
@@ -1495,6 +1496,10 @@ instance ToJSON LT.Text where
1495 toEncoding = E.lazyText
1496 toEncoding = E.lazyText
1496 {-# INLINE toEncoding #-}
1497 {-# INLINE toEncoding #-}
1497
1498
1499+instance ToJSONKey LT.Text where
1500+ toJSONKey = toJSONKeyText LT.toStrict
1501+
1502+
1498instance ToJSON Version where
1503instance ToJSON Version where
1499 toJSON = toJSON . showVersion
1504 toJSON = toJSON . showVersion
1500 {-# INLINE toJSON #-}
1505 {-# INLINE toJSON #-}
@@ -1502,6 +1507,9 @@ instance ToJSON Version where
1502 toEncoding = toEncoding . showVersion
1507 toEncoding = toEncoding . showVersion
1503 {-# INLINE toEncoding #-}
1508 {-# INLINE toEncoding #-}
1504
1509
1510+instance ToJSONKey Version where
1511+ toJSONKey = toJSONKeyText (T.pack . showVersion)
1512+
1505-------------------------------------------------------------------------------
1513-------------------------------------------------------------------------------
1506-- semigroups NonEmpty
1514-- semigroups NonEmpty
1507-------------------------------------------------------------------------------
1515-------------------------------------------------------------------------------
@@ -1552,6 +1560,79 @@ instance (ToJSON a) => ToJSON (DList.DList a) where
1552 toEncoding = toEncoding1
1560 toEncoding = toEncoding1
1553 {-# INLINE toEncoding #-}
1561 {-# INLINE toEncoding #-}
1554
1562
1563+-------------------------------------------------------------------------------
1564+-- transformers - Functors
1565+-------------------------------------------------------------------------------
1566+
1567+instance ToJSON1 Identity where
1568+ liftToJSON t _ (Identity a) = t a
1569+ {-# INLINE liftToJSON #-}
1570+
1571+ liftToJSONList _ tl xs = tl (map runIdentity xs)
1572+ {-# INLINE liftToJSONList #-}
1573+
1574+ liftToEncoding t _ (Identity a) = t a
1575+ {-# INLINE liftToEncoding #-}
1576+
1577+ liftToEncodingList _ tl xs = tl (map runIdentity xs)
1578+ {-# INLINE liftToEncodingList #-}
1579+
1580+instance (ToJSON a) => ToJSON (Identity a) where
1581+ toJSON = toJSON1
1582+ {-# INLINE toJSON #-}
1583+
1584+ toJSONList = liftToJSONList toJSON toJSONList
1585+ {-# INLINE toJSONList #-}
1586+
1587+ toEncoding = toEncoding1
1588+ {-# INLINE toEncoding #-}
1589+
1590+ toEncodingList = liftToEncodingList toEncoding toEncodingList
1591+ {-# INLINE toEncodingList #-}
1592+
1593+instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where
1594+ toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey
1595+ toJSONKeyList = contramapToJSONKeyFunction (map runIdentity) toJSONKeyList
1596+
1597+
1598+instance (ToJSON1 f, ToJSON1 g) => ToJSON1 (Compose f g) where
1599+ liftToJSON tv tvl (Compose x) = liftToJSON g gl x
1600+ where
1601+ g = liftToJSON tv tvl
1602+ gl = liftToJSONList tv tvl
1603+ {-# INLINE liftToJSON #-}
1604+
1605+ liftToJSONList te tel xs = liftToJSONList g gl (map getCompose xs)
1606+ where
1607+ g = liftToJSON te tel
1608+ gl = liftToJSONList te tel
1609+ {-# INLINE liftToJSONList #-}
1610+
1611+ liftToEncoding te tel (Compose x) = liftToEncoding g gl x
1612+ where
1613+ g = liftToEncoding te tel
1614+ gl = liftToEncodingList te tel
1615+ {-# INLINE liftToEncoding #-}
1616+
1617+ liftToEncodingList te tel xs = liftToEncodingList g gl (map getCompose xs)
1618+ where
1619+ g = liftToEncoding te tel
1620+ gl = liftToEncodingList te tel
1621+ {-# INLINE liftToEncodingList #-}
1622+
1623+instance (ToJSON1 f, ToJSON1 g, ToJSON a) => ToJSON (Compose f g a) where
1624+ toJSON = toJSON1
1625+ {-# INLINE toJSON #-}
1626+
1627+ toJSONList = liftToJSONList toJSON toJSONList
1628+ {-# INLINE toJSONList #-}
1629+
1630+ toEncoding = toEncoding1
1631+ {-# INLINE toEncoding #-}
1632+
1633+ toEncodingList = liftToEncodingList toEncoding toEncodingList
1634+ {-# INLINE toEncodingList #-}
1635+
1555-------------------------------------------------------------------------------
1636-------------------------------------------------------------------------------
1556-- containers
1637-- containers
1557-------------------------------------------------------------------------------
1638-------------------------------------------------------------------------------
@@ -1617,14 +1698,14 @@ instance ToJSON a => ToJSON (IntMap.IntMap a) where
1617
1698
1618instance ToJSONKey k => ToJSON1 (M.Map k) where
1699instance ToJSONKey k => ToJSON1 (M.Map k) where
1619 liftToJSON g _ = case toJSONKey of
1700 liftToJSON g _ = case toJSONKey of
1620− ToJSONKeyText (f,_) -> Object . mapHashKeyVal f g
1701+ ToJSONKeyText f _ -> Object . mapHashKeyVal f g
1621− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . M.toList
1702+ ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . M.toList
1622 {-# INLINE liftToJSON #-}
1703 {-# INLINE liftToJSON #-}
1623
1704
1624 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
1705 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> M.Map k a -> Encoding
1625 liftToEncoding g _ = case toJSONKey of
1706 liftToEncoding g _ = case toJSONKey of
1626− ToJSONKeyText (_,f) -> dict f g M.foldrWithKey
1707+ ToJSONKeyText _ f -> dict f g M.foldrWithKey
1627− ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . M.toList
1708+ ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . M.toList
1628 where
1709 where
1629 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
1710 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
1630 pairEncoding f (a, b) = tuple $ f a >*< g b
1711 pairEncoding f (a, b) = tuple $ f a >*< g b
@@ -1736,14 +1817,14 @@ instance (ToJSON a) => ToJSON (HashSet.HashSet a) where
1736
1817
1737instance ToJSONKey k => ToJSON1 (H.HashMap k) where
1818instance ToJSONKey k => ToJSON1 (H.HashMap k) where
1738 liftToJSON g _ = case toJSONKey of
1819 liftToJSON g _ = case toJSONKey of
1739− ToJSONKeyText (f,_) -> Object . mapKeyVal f g
1820+ ToJSONKeyText f _ -> Object . mapKeyVal f g
1740− ToJSONKeyValue (f,_) -> Array . V.fromList . map (toJSONPair f g) . H.toList
1821+ ToJSONKeyValue f _ -> Array . V.fromList . map (toJSONPair f g) . H.toList
1741 {-# INLINE liftToJSON #-}
1822 {-# INLINE liftToJSON #-}
1742
1823
1743 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding
1824 -- liftToEncoding :: forall a. (a -> Encoding) -> ([a] -> Encoding) -> H.HashMap k a -> Encoding
1744 liftToEncoding g _ = case toJSONKey of
1825 liftToEncoding g _ = case toJSONKey of
1745− ToJSONKeyText (_,f) -> dict f g H.foldrWithKey
1826+ ToJSONKeyText _ f -> dict f g H.foldrWithKey
1746− ToJSONKeyValue (_,f) -> listEncoding (pairEncoding f) . H.toList
1827+ ToJSONKeyValue _ f -> listEncoding (pairEncoding f) . H.toList
1747 where
1828 where
1748 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
1829 -- pairEncoding :: (k -> Encoding) -> (k, a) -> Encoding
1749 pairEncoding f (a, b) = tuple $ f a >*< g b
1830 pairEncoding f (a, b) = tuple $ f a >*< g b
@@ -1823,13 +1904,12 @@ instance ToJSONKey UTCTime where
1823 toJSONKey = toJSONKeyTextEnc E.utcTime
1904 toJSONKey = toJSONKeyTextEnc E.utcTime
1824
1905
1825-- | Encode something t a JSON string.
1906-- | Encode something t a JSON string.
1826−stringEncoding :: Encoding -> Value
1907+stringEncoding :: Encoding' Text -> Value
1827stringEncoding = String
1908stringEncoding = String
1828 . T.dropAround (== '"')
1909 . T.dropAround (== '"')
1829 . T.decodeLatin1
1910 . T.decodeLatin1
1830 . L.toStrict
1911 . L.toStrict
1831− . B.toLazyByteString
1912+ . E.encodingToLazyByteString
1832− . fromEncoding
1833{-# INLINE stringEncoding #-}
1913{-# INLINE stringEncoding #-}
1834
1914
1835instance ToJSON NominalDiffTime where
1915instance ToJSON NominalDiffTime where
@@ -1922,29 +2002,17 @@ instance ToJSONKey b => ToJSONKey (Tagged a b) where
1922-- Instances for converting t map keys
2002-- Instances for converting t map keys
1923-------------------------------------------------------------------------------
2003-------------------------------------------------------------------------------
1924
2004
1925−-- | TODO: Move ToJSONKEyFunction to .Types(.Internal),
1926−-- export and document this function from there
1927−toJSONKeyTextEnc :: (a -> Encoding) -> ToJSONKeyFunction a
1928−toJSONKeyTextEnc e = ToJSONKeyText
1929− -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm
1930− ( T.dropAround (== '"') . T.decodeLatin1 . L.toStrict . B.toLazyByteString . fromEncoding . e
1931− , e
1932− )
1933−
1934instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)
2005instance (ToJSON a, ToJSON b) => ToJSONKey (a,b)
1935instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)
2006instance (ToJSON a, ToJSON b, ToJSON c) => ToJSONKey (a,b,c)
1936instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)
2007instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d) => ToJSONKey (a,b,c,d)
1937
2008
1938instance ToJSONKey Char where
2009instance ToJSONKey Char where
1939− toJSONKey = ToJSONKeyText (T.singleton, toEncoding)
2010+ toJSONKey = ToJSONKeyText T.singleton (E.string . (:[]))
1940− toJSONKeyList = ToJSONKeyText (T.pack, toEncoding . T.pack)
2011+ toJSONKeyList = toJSONKeyText T.pack
1941
2012
1942instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where
2013instance (ToJSONKey a, ToJSON a) => ToJSONKey [a] where
1943 toJSONKey = toJSONKeyList
2014 toJSONKey = toJSONKeyList
1944
2015
1945−instance (ToJSONKey a, ToJSON a) => ToJSONKey (Identity a) where
1946− toJSONKey = contramapToJSONKeyFunction runIdentity toJSONKey
1947−
1948-------------------------------------------------------------------------------
2016-------------------------------------------------------------------------------
1949-- Tuple instances, see tuple-instances-to.hs
2017-- Tuple instances, see tuple-instances-to.hs
1950-------------------------------------------------------------------------------
2018-------------------------------------------------------------------------------
aeson.cabal+15−8
@@ -63,18 +63,23 @@ library
63
63
64 exposed-modules:
64 exposed-modules:
65 Data.Aeson
65 Data.Aeson
66− Data.Aeson.Encode
67 Data.Aeson.Encoding
66 Data.Aeson.Encoding
68− Data.Aeson.Encoding.Internal
69− Data.Aeson.Internal
70− Data.Aeson.Internal.Time
71 Data.Aeson.Parser
67 Data.Aeson.Parser
68+ Data.Aeson.Text
72 Data.Aeson.Types
69 Data.Aeson.Types
73 Data.Aeson.TH
70 Data.Aeson.TH
74
71
72+ Data.Aeson.Encoding.Internal
73+ Data.Aeson.Internal
74+ Data.Aeson.Internal.Time
75+
76+ -- Deprecated modules
77+ exposed-modules:
78+ Data.Aeson.Encode
79+
75 other-modules:
80 other-modules:
76− Data.Aeson.Encode.Builder
81+ Data.Aeson.Encoding.Builder
77− Data.Aeson.Functions
82+ Data.Aeson.Internal.Functions
78 Data.Aeson.Parser.Internal
83 Data.Aeson.Parser.Internal
79 Data.Aeson.Parser.Time
84 Data.Aeson.Parser.Time
80 Data.Aeson.Types.FromJSON
85 Data.Aeson.Types.FromJSON
@@ -155,7 +160,7 @@ test-suite tests
155 dlist,
160 dlist,
156 generic-deriving >= 1.10 && < 1.11,
161 generic-deriving >= 1.10 && < 1.11,
157 ghc-prim >= 0.2,
162 ghc-prim >= 0.2,
158− hashable >= 1.1.2.0,
163+ hashable >= 1.2.4.0,
159 tagged,
164 tagged,
160 template-haskell,
165 template-haskell,
161 test-framework,
166 test-framework,
@@ -169,7 +174,9 @@ test-suite tests
169 quickcheck-instances >=0.3.12
174 quickcheck-instances >=0.3.12
170
175
171 if !impl(ghc >= 8.0)
176 if !impl(ghc >= 8.0)
177+ build-depends:
172− build-depends: semigroups >= 0.16.1 && < 0.19
178+ semigroups >= 0.16.1 && < 0.19,
179+ transformers >= 0.2.2.0
173
180
174 if !impl(ghc >= 7.10)
181 if !impl(ghc >= 7.10)
175 build-depends: nats >=1 && <1.2
182 build-depends: nats >=1 && <1.2
benchmarks/CompareWithJSON.hs+1−1
@@ -4,8 +4,8 @@ import Blaze.ByteString.Builder (toLazyByteString)
4import Blaze.ByteString.Builder.Char.Utf8 (fromString)
4import Blaze.ByteString.Builder.Char.Utf8 (fromString)
5import Control.DeepSeq (NFData(rnf))
5import Control.DeepSeq (NFData(rnf))
6import Criterion.Main
6import Criterion.Main
7−import qualified Data.Aeson.Encode as A
8import qualified Data.Aeson as A
7import qualified Data.Aeson as A
8+import qualified Data.Aeson.Text as A
9import qualified Data.ByteString.Lazy as BL
9import qualified Data.ByteString.Lazy as BL
10import qualified Text.JSON as J
10import qualified Text.JSON as J
11import qualified Data.Text.Lazy as TL
11import qualified Data.Text.Lazy as TL
benchmarks/Micro.hs+1−1
@@ -1,7 +1,7 @@
1module Main (main) where
1module Main (main) where
2
2
3import Criterion.Main
3import Criterion.Main
4−import qualified Data.Aeson.Encode.Builder as AB
4+import qualified Data.Aeson.Encoding.Builder as AB
5import qualified Data.ByteString.Builder as B
5import qualified Data.ByteString.Builder as B
6import qualified Data.Text as T
6import qualified Data.Text as T
7
7
benchmarks/aeson-benchmarks.cabal+7−6
@@ -9,17 +9,18 @@ library
9
9
10 exposed-modules:
10 exposed-modules:
11 Data.Aeson
11 Data.Aeson
12− Data.Aeson.Encode
13 Data.Aeson.Encoding
12 Data.Aeson.Encoding
14− Data.Aeson.Encoding.Internal
15− Data.Aeson.Internal
16− Data.Aeson.Internal.Time
17 Data.Aeson.Parser
13 Data.Aeson.Parser
14+ Data.Aeson.Text
18 Data.Aeson.Types
15 Data.Aeson.Types
19 Data.Aeson.TH
16 Data.Aeson.TH
20
17
21− Data.Aeson.Encode.Builder
18+ Data.Aeson.Encoding.Internal
19+ Data.Aeson.Internal
20+ Data.Aeson.Internal.Time
21+
22+ Data.Aeson.Encoding.Builder
22− Data.Aeson.Functions
23+ Data.Aeson.Internal.Functions
23 Data.Aeson.Parser.Internal
24 Data.Aeson.Parser.Internal
24 Data.Aeson.Parser.Time
25 Data.Aeson.Parser.Time
25 Data.Aeson.Types.FromJSON
26 Data.Aeson.Types.FromJSON
include/overlapping-compat.h−7
@@ -1,15 +1,8 @@
1#if __GLASGOW_HASKELL__ >= 710
1#if __GLASGOW_HASKELL__ >= 710
2#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
2#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}
3#define OVERLAPPING_ {-# OVERLAPPING #-}
3#define OVERLAPPING_ {-# OVERLAPPING #-}
4−#ifdef NEEDS_INCOHERENT
5−#define INCOHERENT_ {-# INCOHERENT #-}
6−#endif
7#else
4#else
8{-# LANGUAGE OverlappingInstances #-}
5{-# LANGUAGE OverlappingInstances #-}
9#define OVERLAPPABLE_
6#define OVERLAPPABLE_
10#define OVERLAPPING_
7#define OVERLAPPING_
11−#ifdef NEEDS_INCOHERENT
12−{-# LANGUAGE IncoherentInstances #-}
13−#define INCOHERENT_
14−#endif
15#endif
8#endif
tests/Instances.hs+24−1
@@ -1,5 +1,6 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE StandaloneDeriving #-}
6{-# LANGUAGE StandaloneDeriving #-}
@@ -23,8 +24,11 @@ import Data.Aeson.Types
23import Control.Applicative (Const(..), empty)
24import Control.Applicative (Const(..), empty)
24import Data.Tagged (Tagged(..))
25import Data.Tagged (Tagged(..))
25import Data.Proxy (Proxy(..))
26import Data.Proxy (Proxy(..))
27+import Data.Functor.Identity (Identity (..))
28+import Data.Functor.Compose (Compose (..))
26import Functions
29import Functions
27import qualified Data.DList as DList
30import qualified Data.DList as DList
31+import qualified Data.HashMap.Strict as HM
28
32
29import Data.Orphans ()
33import Data.Orphans ()
30import Test.QuickCheck.Instances ()
34import Test.QuickCheck.Instances ()
@@ -57,8 +61,20 @@ instance ApproxEq UTCTime where
57instance ApproxEq DotNetTime where
61instance ApproxEq DotNetTime where
58 (=~) = (=~) `on` fromDotNetTime
62 (=~) = (=~) `on` fromDotNetTime
59
63
64+instance ApproxEq Float where
65+ a =~ b
66+ | isNaN a && isNaN b = True
67+ | otherwise = approxEq a b
68+
60instance ApproxEq Double where
69instance ApproxEq Double where
70+ a =~ b
71+ | isNaN a && isNaN b = True
61− (=~) = approxEq
72+ | otherwise = approxEq a b
73+
74+instance (ApproxEq k, Eq v) => ApproxEq (HM.HashMap k v) where
75+ a =~ b = and $ zipWith eq (HM.toList a) (HM.toList b)
76+ where
77+ eq (x,y) (u,v) = x =~ u && y == v
62
78
63-- Test-related types.
79-- Test-related types.
64
80
@@ -180,3 +196,10 @@ instance Arbitrary a => Arbitrary (Const a b) where
180
196
181instance Arbitrary a => Arbitrary (DList.DList a) where
197instance Arbitrary a => Arbitrary (DList.DList a) where
182 arbitrary = DList.fromList <$> arbitrary
198 arbitrary = DList.fromList <$> arbitrary
199+
200+-- would like to have -- https://github.com/nick8325/quickcheck/issues/73
201+instance Arbitrary a => Arbitrary (Identity a) where
202+ arbitrary = Identity <$> arbitrary
203+
204+instance Arbitrary (f (g a)) => Arbitrary (Compose f g a) where
205+ arbitrary = Compose <$> arbitrary
tests/Properties.hs+45−2
@@ -1,13 +1,15 @@
1{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
1{-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables #-}
2
2
3+-- For Arbitrary Compose
4+{-# LANGUAGE FlexibleContexts #-}
5+
3module Properties where
6module Properties where
4
7
5import Prelude ()
8import Prelude ()
6import Prelude.Compat
9import Prelude.Compat
7
10
8import Control.Applicative (Const)
11import Control.Applicative (Const)
9−import Data.Aeson (eitherDecode)
12+import Data.Aeson (eitherDecode, encode)
10−import Data.Aeson.Encode (encode)
11import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)
13import Data.Aeson.Internal (IResult(..), formatError, ifromJSON, iparse)
12import Data.Aeson.Parser (value)
14import Data.Aeson.Parser (value)
13import Data.Aeson.Types
15import Data.Aeson.Types
@@ -17,6 +19,7 @@ import Data.Sequence (Seq)
17import Data.DList (DList)
19import Data.DList (DList)
18import Data.Hashable (Hashable)
20import Data.Hashable (Hashable)
19import Data.HashMap.Strict (HashMap)
21import Data.HashMap.Strict (HashMap)
22+import Data.Functor.Compose (Compose (..))
20import Data.Map (Map)
23import Data.Map (Map)
21import Data.Ratio (Ratio)
24import Data.Ratio (Ratio)
22import Data.List.NonEmpty (NonEmpty)
25import Data.List.NonEmpty (NonEmpty)
@@ -37,6 +40,7 @@ import qualified Data.ByteString.Lazy.Char8 as L
37import qualified Data.HashMap.Strict as H
40import qualified Data.HashMap.Strict as H
38import qualified Data.Map as Map
41import qualified Data.Map as Map
39import qualified Data.Text as T
42import qualified Data.Text as T
43+import qualified Data.Text.Lazy as LT
40import qualified Data.Vector as V
44import qualified Data.Vector as V
41
45
42encodeDouble :: Double -> Double -> Property
46encodeDouble :: Double -> Double -> Property
@@ -137,6 +141,7 @@ isObjectWithSingleField _ = False
137
141
138--------------------------------------------------------------------------------
142--------------------------------------------------------------------------------
139
143
144+
140tests :: Test
145tests :: Test
141tests = testGroup "properties" [
146tests = testGroup "properties" [
142 testGroup "encode" [
147 testGroup "encode" [
@@ -151,6 +156,7 @@ tests = testGroup "properties" [
151 , testProperty "Integer" $ roundTripEq (1 :: Integer)
156 , testProperty "Integer" $ roundTripEq (1 :: Integer)
152 , testProperty "String" $ roundTripEq ("" :: String)
157 , testProperty "String" $ roundTripEq ("" :: String)
153 , testProperty "Text" $ roundTripEq T.empty
158 , testProperty "Text" $ roundTripEq T.empty
159+ , testProperty "Lazy Text" $ roundTripEq LT.empty
154 , testProperty "Foo" $ roundTripEq (undefined :: Foo)
160 , testProperty "Foo" $ roundTripEq (undefined :: Foo)
155 , testProperty "Day" $ roundTripEq (undefined :: Day)
161 , testProperty "Day" $ roundTripEq (undefined :: Day)
156 , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
162 , testProperty "DotNetTime" $ roundTripEq (undefined :: Approx DotNetTime)
@@ -168,6 +174,41 @@ tests = testGroup "properties" [
168 , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)
174 , testProperty "Seq" $ roundTripEq (undefined :: Seq Int)
169 , testProperty "Rational" $ roundTripEq (undefined :: Rational)
175 , testProperty "Rational" $ roundTripEq (undefined :: Rational)
170 , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)
176 , testProperty "Ratio Int" $ roundTripEq (undefined :: Ratio Int)
177+ , testGroup "functors"
178+ [ testProperty "Identity Char" $ roundTripEq (undefined :: I Int)
179+
180+ , testProperty "Identity Char" $ roundTripEq (undefined :: I Char)
181+ , testProperty "Identity [Char]" $ roundTripEq (undefined :: I [Char])
182+ , testProperty "[Identity Char]" $ roundTripEq (undefined :: [I Char])
183+
184+ , testProperty "Compose I I Int" $ roundTripEq (undefined :: Compose I I Int)
185+ , testProperty "Compose [] I Int" $ roundTripEq (undefined :: Compose [] I Int)
186+ , testProperty "Compose I [] Int" $ roundTripEq (undefined :: Compose I [] Int)
187+ , testProperty "Compose [] [] Int" $ roundTripEq (undefined :: Compose [] [] Int)
188+
189+ , testProperty "Compose I I Char" $ roundTripEq (undefined :: Compose I I Char)
190+ , testProperty "Compose [] I Char" $ roundTripEq (undefined :: Compose [] I Char)
191+ , testProperty "Compose I [] Char" $ roundTripEq (undefined :: Compose I [] Char)
192+ , testProperty "Compose [] [] Char" $ roundTripEq (undefined :: Compose [] [] Char)
193+
194+ , testProperty "Compose3 I I I Char" $ roundTripEq (undefined :: Compose3 I I I Char)
195+ , testProperty "Compose3 I [] I Char" $ roundTripEq (undefined :: Compose3 I [] I Char)
196+ , testProperty "Compose3 I I [] Char" $ roundTripEq (undefined :: Compose3 I I [] Char)
197+ , testProperty "Compose3 I [] [] Char" $ roundTripEq (undefined :: Compose3 I [] [] Char)
198+ , testProperty "Compose3 [] I I Char" $ roundTripEq (undefined :: Compose3 [] I I Char)
199+ , testProperty "Compose3 [] [] I Char" $ roundTripEq (undefined :: Compose3 [] [] I Char)
200+ , testProperty "Compose3 [] I [] Char" $ roundTripEq (undefined :: Compose3 [] I [] Char)
201+ , testProperty "Compose3 [] [] [] Char" $ roundTripEq (undefined :: Compose3 [] [] [] Char)
202+
203+ , testProperty "Compose3' I I I Char" $ roundTripEq (undefined :: Compose3' I I I Char)
204+ , testProperty "Compose3' I [] I Char" $ roundTripEq (undefined :: Compose3' I [] I Char)
205+ , testProperty "Compose3' I I [] Char" $ roundTripEq (undefined :: Compose3' I I [] Char)
206+ , testProperty "Compose3' I [] [] Char" $ roundTripEq (undefined :: Compose3' I [] [] Char)
207+ , testProperty "Compose3' [] I I Char" $ roundTripEq (undefined :: Compose3' [] I I Char)
208+ , testProperty "Compose3' [] [] I Char" $ roundTripEq (undefined :: Compose3' [] [] I Char)
209+ , testProperty "Compose3' [] I [] Char" $ roundTripEq (undefined :: Compose3' [] I [] Char)
210+ , testProperty "Compose3' [] [] [] Char" $ roundTripEq (undefined :: Compose3' [] [] [] Char)
211+ ]
171 , testGroup "ghcGenerics" [
212 , testGroup "ghcGenerics" [
172 testProperty "OneConstructor" $ roundTripEq OneConstructor
213 testProperty "OneConstructor" $ roundTripEq OneConstructor
173 , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
214 , testProperty "Product2" $ roundTripEq (undefined :: Product2 Int Bool)
@@ -192,6 +233,8 @@ tests = testGroup "properties" [
192 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)
233 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)
193 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)
234 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)
194#endif
235#endif
236+ , testProperty "Version" $ roundTripKey (undefined :: Version)
237+ , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)
195 ]
238 ]
196 , testGroup "toFromJSON" [
239 , testGroup "toFromJSON" [
197 testProperty "Integer" (toFromJSON :: Integer -> Property)
240 testProperty "Integer" (toFromJSON :: Integer -> Property)
tests/Types.hs+6
@@ -12,6 +12,12 @@ import Data.Data
12import Data.Text
12import Data.Text
13import GHC.Generics
13import GHC.Generics
14import Test.QuickCheck (Property, counterexample)
14import Test.QuickCheck (Property, counterexample)
15+import Data.Functor.Compose (Compose (..))
16+import Data.Functor.Identity (Identity (..))
17+
18+type I = Identity
19+type Compose3 f g h = Compose (Compose f g) h
20+type Compose3' f g h = Compose f (Compose g h)
15
21
16data Foo = Foo {
22data Foo = Foo {
17 fooInt :: Int
23 fooInt :: Int
tests/UnitTests.hs+95−24
@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, GeneralizedNewtypeDeriving #-}
1+{-# LANGUAGE CPP, GADTs, DeriveGeneric, OverloadedStrings, ScopedTypeVariables, TemplateHaskell, GeneralizedNewtypeDeriving #-}
2#if __GLASGOW_HASKELL__ >= 708
2#if __GLASGOW_HASKELL__ >= 708
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
4#endif
4#endif
@@ -10,16 +10,21 @@ module UnitTests (ioTests, tests) where
10import Prelude ()
10import Prelude ()
11import Prelude.Compat
11import Prelude.Compat
12
12
13+import Types (I, Compose3, Compose3', Approx(..))
14+import Instances ()
15+
13import Control.Applicative (Const(..))
16import Control.Applicative (Const(..))
14import Control.Monad (forM)
17import Control.Monad (forM)
15import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))
18import Data.Aeson (FromJSONKeyFunction(..), FromJSONKey(..), decode, eitherDecode, encode, genericToJSON, genericToEncoding, object, FromJSON(..), withObject, (.=), (.:), (.:?), (.:!))
16−import Data.Aeson.Encode (encodeToTextBuilder)
19+import Data.Aeson.Text (encodeToTextBuilder)
17import Data.Aeson.Internal (JSONPathElement(..), formatError)
20import Data.Aeson.Internal (JSONPathElement(..), formatError)
18import Data.Aeson.TH (deriveJSON)
21import Data.Aeson.TH (deriveJSON)
19import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)
22import Data.Aeson.Types (ToJSON(..), Value, camelTo, camelTo2, defaultOptions, omitNothingFields)
20import Data.Char (toUpper)
23import Data.Char (toUpper)
21import Data.Hashable (hash)
24import Data.Hashable (hash)
22import Data.List.NonEmpty (NonEmpty(..))
25import Data.List.NonEmpty (NonEmpty(..))
26+import Data.Functor.Compose (Compose (..))
27+import Data.Functor.Identity (Identity (..))
23import Data.Maybe (fromMaybe)
28import Data.Maybe (fromMaybe)
24import Data.Proxy (Proxy(..))
29import Data.Proxy (Proxy(..))
25import Data.Sequence (Seq)
30import Data.Sequence (Seq)
@@ -42,6 +47,7 @@ import qualified Data.Text.Lazy.Encoding as LT
42import qualified Data.Sequence as Seq
47import qualified Data.Sequence as Seq
43import qualified Data.DList as DList
48import qualified Data.DList as DList
44import qualified Data.HashMap.Strict as HM
49import qualified Data.HashMap.Strict as HM
50+import qualified Data.Map as M
45
51
46tests :: Test
52tests :: Test
47tests = testGroup "unit" [
53tests = testGroup "unit" [
@@ -70,6 +76,7 @@ tests = testGroup "unit" [
70 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
76 , testGroup ".:, .:?, .:!" $ fmap (testCase "-") dotColonMark
71 , testGroup "To JSON representation" $ fmap (testCase "-") jsonEncoding
77 , testGroup "To JSON representation" $ fmap (testCase "-") jsonEncoding
72 , testGroup "From JSON representation" $ fmap (testCase "-") jsonDecoding
78 , testGroup "From JSON representation" $ fmap (testCase "-") jsonDecoding
79+ , testGroup "To/From JSON representation" $ fmap assertJsonExample jsonExamples
73 , testGroup "JSONPath" $ fmap (testCase "-") jsonPath
80 , testGroup "JSONPath" $ fmap (testCase "-") jsonPath
74 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
81 , testGroup "Hashable laws" $ fmap (testCase "-") hashableLaws
75 , testGroup "Issue #351" $ fmap (testCase "-") issue351
82 , testGroup "Issue #351" $ fmap (testCase "-") issue351
@@ -234,31 +241,96 @@ dotColonMark = [
234-----------------------------------------------------------------------------
241-----------------------------------------------------------------------------
235
242
236jsonEncoding :: [Assertion]
243jsonEncoding :: [Assertion]
237−jsonEncoding = [
244+jsonEncoding =
245+ [
246+ -- https://github.com/bos/aeson/issues/376
247+ assertEqual "Just Nothing" "null" $ encode (Just Nothing :: Maybe (Maybe Int))
248+ -- infinities cannot be recovered, null is decoded as NaN
249+ , assertEqual "inf :: Double" "null" $ encode (Approx $ 1/0 :: Approx Double)
250+ ]
251+
252+data Example where
253+ Example
254+ :: (Eq a, Show a, ToJSON a, FromJSON a)
255+ => String -> L.ByteString -> a -> Example
256+
257+assertJsonExample :: Example -> Test
258+assertJsonExample (Example name bs val) = testCase name $ do
259+ assertEqual "encode" bs (encode val)
260+ assertEqual "decode" (Just val) (decode bs)
261+
262+jsonExamples :: [Example]
263+jsonExamples =
264+ [
238− assertEqual "Either Left" "{\"Left\":1}" $ encode (Left 1 :: Either Int Int)
265+ Example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)
239− , assertEqual "Either Right" "{\"Right\":1}" $ encode (Right 1 :: Either Int Int)
266+ , Example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)
240− , assertEqual "Nothing" "null" $ encode (Nothing :: Maybe Int)
267+ , Example "Nothing" "null" (Nothing :: Maybe Int)
241− , assertEqual "Just" "1" $ encode (Just 1 :: Maybe Int)
268+ , Example "Just" "1" (Just 1 :: Maybe Int)
242− , assertEqual "Just Nothing" "null" $ encode (Just Nothing :: Maybe (Maybe Int))
243− , assertEqual "Proxy Int" "null" $ encode (Proxy :: Proxy Int)
269+ , Example "Proxy Int" "null" (Proxy :: Proxy Int)
244− , assertEqual "Tagged Char Int" "1" $ encode (Tagged 1 :: Tagged Char Int)
270+ , Example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)
245#if __GLASGOW_HASKELL__ >= 708
271#if __GLASGOW_HASKELL__ >= 708
246 -- Test Tagged instance is polykinded
272 -- Test Tagged instance is polykinded
247− , assertEqual "Tagged 123 Int" "1" $ encode (Tagged 1 :: Tagged 123 Int)
273+ , Example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)
248#endif
274#endif
249− , assertEqual "Const Char Int" "\"c\"" $ encode (Const 'c' :: Const Char Int)
275+ , Example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)
250− , assertEqual "Tuple" "[1,2]" $ encode ((1, 2) :: (Int, Int))
276+ , Example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))
251− , assertEqual "NonEmpty" "[1,2,3]" $ encode (1 :| [2, 3] :: NonEmpty Int)
277+ , Example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)
252− , assertEqual "Seq" "[1,2,3]" $ encode (Seq.fromList [1, 2, 3] :: Seq.Seq Int)
278+ , Example "Seq" "[1,2,3]" (Seq.fromList [1, 2, 3] :: Seq.Seq Int)
253− , assertEqual "DList" "[1,2,3]" $ encode (DList.fromList [1, 2, 3] :: DList.DList Int)
279+ , Example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)
254− , assertEqual "()" "[]" $ encode ()
280+ , Example "()" "[]" ()
255− , assertEqual "HashMap Int Int" "{\"0\":1,\"2\":3}" $ encode (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)
281+
282+ , Example "HashMap Int Int" "{\"0\":1,\"2\":3}" (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)
283+ , Example "Map Int Int" "{\"0\":1,\"2\":3}" (M.fromList [(0,1),(2,3)] :: M.Map Int Int)
284+ , Example "Map (Tagged Int Int) Int" "{\"0\":1,\"2\":3}" (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)
285+ , Example "Map [Int] Int" "[[[0],1],[[2],3]]" (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)
286+ , Example "Map [Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [("ab",1),("cd",3)] :: M.Map [Char] Int)
287+ , Example "Map [I Char] Int" "{\"ab\":1,\"cd\":3}" (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)
288+
256− , assertEqual "nan :: Double" "null" $ encode (0/0 :: Double)
289+ , Example "nan :: Double" "null" (Approx $ 0/0 :: Approx Double)
257− , assertEqual "inf :: Double" "null" $ encode (1/0 :: Double)
290+
258 -- Three separate cases, as ordering in HashMap is not defined
291 -- Three separate cases, as ordering in HashMap is not defined
259− , assertEqual "HashMap Float Int, NaN" "{\"NaN\":1}" $ encode (HM.singleton (0/0) 1 :: HM.HashMap Float Int)
292+ , Example "HashMap Float Int, NaN" "{\"NaN\":1}" (Approx $ HM.singleton (0/0) 1 :: Approx (HM.HashMap Float Int))
260− , assertEqual "HashMap Float Int, Infinity" "{\"Infinity\":1}" $ encode (HM.singleton (1/0) 1 :: HM.HashMap Float Int)
293+ , Example "HashMap Float Int, Infinity" "{\"Infinity\":1}" (HM.singleton (1/0) 1 :: HM.HashMap Float Int)
261− , assertEqual "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" $ encode (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)
294+ , Example "HashMap Float Int, +Infinity" "{\"-Infinity\":1}" (HM.singleton (negate 1/0) 1 :: HM.HashMap Float Int)
295+
296+ -- Functors
297+ , Example "Identity Int" "1" (pure 1 :: Identity Int)
298+
299+ , Example "Identity Char" "\"x\"" (pure 'x' :: Identity Char)
300+ , Example "Identity String" "\"foo\"" (pure "foo" :: Identity String)
301+ , Example "[Identity Char]" "\"xy\"" ([pure 'x', pure 'y'] :: [Identity Char])
302+
303+ , Example "Maybe Char" "\"x\"" (pure 'x' :: Maybe Char)
304+ , Example "Maybe String" "\"foo\"" (pure "foo" :: Maybe String)
305+ , Example "Maybe [Identity Char]" "\"xy\"" (pure [pure 'x', pure 'y'] :: Maybe [Identity Char])
306+
307+ , Example "Compose I I Int" "1" (pure 1 :: Compose I I Int)
308+ , Example "Compose I [] Int" "[1]" (pure 1 :: Compose I [] Int)
309+ , Example "Compose [] I Int" "[1]" (pure 1 :: Compose [] I Int)
310+ , Example "Compose [] [] Int" "[[1]]" (pure 1 :: Compose [] [] Int)
311+
312+ , Example "Compose I I Char" "\"x\"" (pure 'x' :: Compose I I Char)
313+ , Example "Compose I [] Char" "\"x\"" (pure 'x' :: Compose I [] Char)
314+ , Example "Compose [] I Char" "\"x\"" (pure 'x' :: Compose [] I Char)
315+ , Example "Compose [] [] Char" "[\"x\"]" (pure 'x' :: Compose [] [] Char)
316+
317+ , Example "Compose3 I I I Char" "\"x\"" (pure 'x' :: Compose3 I I I Char)
318+ , Example "Compose3 I I [] Char" "\"x\"" (pure 'x' :: Compose3 I I [] Char)
319+ , Example "Compose3 I [] I Char" "\"x\"" (pure 'x' :: Compose3 I [] I Char)
320+ , Example "Compose3 I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3 I [] [] Char)
321+ , Example "Compose3 [] I I Char" "\"x\"" (pure 'x' :: Compose3 [] I I Char)
322+ , Example "Compose3 [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3 [] I [] Char)
323+ , Example "Compose3 [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3 [] [] I Char)
324+ , Example "Compose3 [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3 [] [] [] Char)
325+
326+ , Example "Compose3' I I I Char" "\"x\"" (pure 'x' :: Compose3' I I I Char)
327+ , Example "Compose3' I I [] Char" "\"x\"" (pure 'x' :: Compose3' I I [] Char)
328+ , Example "Compose3' I [] I Char" "\"x\"" (pure 'x' :: Compose3' I [] I Char)
329+ , Example "Compose3' I [] [] Char" "[\"x\"]" (pure 'x' :: Compose3' I [] [] Char)
330+ , Example "Compose3' [] I I Char" "\"x\"" (pure 'x' :: Compose3' [] I I Char)
331+ , Example "Compose3' [] I [] Char" "[\"x\"]" (pure 'x' :: Compose3' [] I [] Char)
332+ , Example "Compose3' [] [] I Char" "[\"x\"]" (pure 'x' :: Compose3' [] [] I Char)
333+ , Example "Compose3' [] [] [] Char" "[[\"x\"]]" (pure 'x' :: Compose3' [] [] [] Char)
262 ]
334 ]
263
335
264jsonDecoding :: [Assertion]
336jsonDecoding :: [Assertion]
@@ -322,7 +394,6 @@ fromJSONKeyAssertions =
322 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
394 , assertIsCoerce "Tagged Int Text" (fromJSONKey :: FromJSONKeyFunction (Tagged Int Text))
323 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
395 , assertIsCoerce "MyText" (fromJSONKey :: FromJSONKeyFunction MyText)
324
396
325−-- Why this doesn't work on older GHC?
326#if __GLASGOW_HASKELL__ >= 710
397#if __GLASGOW_HASKELL__ >= 710
327 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
398 , assertIsCoerce' "MyText'" (fromJSONKey :: FromJSONKeyFunction MyText')
328#endif
399#endif