master..8bcf200 · typeable/aeson

git.iko.soy/typeable/aeson

on 8bcf200 help sign in

.gitignore−1

since splitsnapshots

unifiedsplit

@@ -5,7 +5,6 @@ dist-newstyle

5cabal.sandbox.config

6.stack-work/

7.stack-work-bench/

8−*.yaml.lock

10*.o

9*.o

11*.hi

10*.hi

.hlint.yamldeleted−11

@@ -1,11 +0,0 @@

1−# Ignore some builtin hints

2−- ignore:

3− name: "Reduce duplication"

4− within:

5− - Data.Aeson.Types.ToJSON

6−- ignore:

7− name: "Eta reduce"

8−- ignore:

9− name: "Use newtype instead of data"

10− within:

11− - Data.Aeson.Types.Internal

.travis.yml+23−34

@@ -12,58 +12,47 @@ cache:

12 - $HOME/.stack

13 - $HOME/.cabsnap

14 - $HOME/.cabal/packages

15− - $HOME/.cabal/store

17before_cache:

16before_cache:

18 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

17 - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log

19− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.*

18+ - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar

20− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json

21− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache

22− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar

23− - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx

25matrix:

20matrix:

26 include:

21 include:

27−

28− - env: BUILD=hlint CABALVER=2.2 GHCVER=8.4.4

22+ - env: BUILD=hlint CABALVER=2.2 GHCVER=8.4.3

29− compiler: ": #GHC 8.4.4"

23+ compiler: ": #GHC 8.4.3"

30− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4], sources: [hvr-ghc]}}

24+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

31−

32− - env: BUILD=stack CABALVER=2.4 GHCVER=8.6.5 STACK_YAML=stack-bench.yaml

25+ - env: BUILD=stack CABALVER=2.2 GHCVER=8.4.3 STACK_YAML=stack-bench.yaml

33− compiler: ": #GHC 8.6.5"

26+ compiler: ": #GHC 8.4.3"

34− addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

27+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

35−

36− - env: BUILD=stack CABALVER=2.2 GHCVER=8.6.5 STACK_YAML=stack-ffi-unescape.yaml

28+ - env: BUILD=stack CABALVER=2.2 GHCVER=8.4.3 STACK_YAML=stack-ffi-unescape.yaml

37− compiler: ": #GHC 8.6.5"

29+ compiler: ": #GHC 8.4.3"

38− addons: {apt: {packages: [cabal-install-2.2,ghc-8.6.5], sources: [hvr-ghc]}}

30+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

39−

31+

40− - env: BUILD=cabal2 CABALVER=3.0 GHCVER=8.8.1

41− compiler: ": #GHC 8.8.1"

42− addons: {apt: {packages: [cabal-install-3.0,ghc-8.8.1], sources: [hvr-ghc]}}

43−

44− - env: BUILD=cabal CABALVER=2.4 GHCVER=8.6.5

32+ - env: BUILD=cabal CABALVER=2.4 GHCVER=8.6.1

45− compiler: ": #GHC 8.6.5"

33+ compiler: ": #GHC 8.6.1"

46− addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.5], sources: [hvr-ghc]}}

34+ addons: {apt: {packages: [cabal-install-2.4,ghc-8.6.1], sources: [hvr-ghc]}}

47−

48− - env: BUILD=cabal CABALVER=2.2 GHCVER=8.4.4

35+ - env: BUILD=cabal CABALVER=2.2 GHCVER=8.4.3

49− compiler: ": #GHC 8.4.4"

36+ compiler: ": #GHC 8.4.3"

50− addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.4], sources: [hvr-ghc]}}

37+ addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.3], sources: [hvr-ghc]}}

51−

52 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.2.2

38 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.2.2

53 compiler: ": #GHC 8.2.2"

39 compiler: ": #GHC 8.2.2"

54 addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}

40 addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}}

55−

56 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2

41 - env: BUILD=cabal CABALVER=2.0 GHCVER=8.0.2

57 compiler: ": #GHC 8.0.2"

42 compiler: ": #GHC 8.0.2"

58 addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}

43 addons: {apt: {packages: [cabal-install-2.0,ghc-8.0.2], sources: [hvr-ghc]}}

59−

60 - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3

44 - env: BUILD=cabal CABALVER=1.22 GHCVER=7.10.3

61 compiler: ": #GHC 7.10.3"

45 compiler: ": #GHC 7.10.3"

62 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}

46 addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}

63−

64 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4

47 - env: BUILD=cabal CABALVER=1.18 GHCVER=7.8.4

65 compiler: ": #GHC 7.8.4"

48 compiler: ": #GHC 7.8.4"

66 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}

49 addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}

50+ - env: BUILD=cabal CABALVER=1.18 GHCVER=7.6.3

51+ compiler: ": #GHC 7.6.3"

52+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}

53+ - env: BUILD=cabal CABALVER=1.18 GHCVER=7.4.2

54+ compiler: ": #GHC 7.4.2"

55+ addons: {apt: {packages: [cabal-install-1.18,ghc-7.4.2], sources: [hvr-ghc]}}

68before_install:

57before_install:

69 - unset CC

58 - unset CC

CONTRIBUTING.md−38

@@ -58,41 +58,3 @@ import Foo as F

58import Qux (Q(..), q)

59import qualified A

60```

61−

62−## Development Workflow (If you plan on using Stack)

63−

64−Here we outline a general workflow new contributors could adopt for a nice incremental development experience.

65−

66−The root folder consists of two stack-*.yaml config files.

67−

68−1. stack-nightly.yaml - Config file defines all the settings to build and test any changes.

69−2. stack-bench.yaml - Used to run benchmark tests.

70−3. stack-ffi-unescape.yaml - This is for replacing certain parts with a C-implementation.

71−

72−Therefore, a ghci development experience would be:

73−

74−1. `stack ghci --stack-yaml stack-nightly.yaml --test`

75−2. :r to recompile

76−3. `main` to run all tests, or `:main --pattern Foo` to run specific tests matched by pattern.

77−

78−Some discussion on this topic can also be found here [here](https://github.com/bos/aeson/issues/733)

79−

80−Of course before submitting a PR, the following steps are recommended:

81−

82−1. 'stack test --stack-yaml stack-nightly.yaml` - Run the entire suite of tests

83−2. `make hlint` - Run hlint on the source folders.

84−3. 'stack test --stack-yaml stack-bench.yaml` - Run the benchmark tests if you believe your changes could affect the benchmarks.

85−

86−## Development Workflow (If you plan on using Cabal)

87−

88−A ghci development experience would be:

89−

90−1. `cabal new-repl test:tests`

91−2. `:r` to recompile

92−3. `Main.main` to run all tests, or `:m Main; :main --pattern Foo` to run specific tests matched by pattern.

93−

94−Of course before submitting a PR, the following steps are recommended:

95−

96−1. `cabal new-test` - Run the entire suite of tests

97−2. `make hlint` - Run hlint on the source folders.

98−3. Uncomment the `benchmarks` line in `cabal.project` - Run the benchmark tests if you believe your changes could affect the benchmarks.

Data/Aeson.hs+2−14

@@ -63,18 +63,11 @@ module Data.Aeson

63 , fromJSON

64 , ToJSON(..)

65 , KeyValue(..)

66− , (<?>)

67− , JSONPath

68 -- ** Keys for maps

66 -- ** Keys for maps

69 , ToJSONKey(..)

67 , ToJSONKey(..)

70 , ToJSONKeyFunction(..)

68 , ToJSONKeyFunction(..)

71 , FromJSONKey(..)

69 , FromJSONKey(..)

72 , FromJSONKeyFunction(..)

70 , FromJSONKeyFunction(..)

73− -- *** Generic keys

74− , GToJSONKey()

75− , genericToJSONKey

76− , GFromJSONKey()

77− , genericFromJSONKey

78 -- ** Liftings to unary and binary type constructors

71 -- ** Liftings to unary and binary type constructors

79 , FromJSON1(..)

72 , FromJSON1(..)

80 , parseJSON1

73 , parseJSON1

@@ -116,10 +109,6 @@ module Data.Aeson

116 , SumEncoding(..)

109 , SumEncoding(..)

117 , camelTo2

110 , camelTo2

118 , defaultTaggedObject

111 , defaultTaggedObject

119− -- ** Options for object keys

120− , JSONKeyOptions

121− , keyModifier

122− , defaultJSONKeyOptions

123

112

124 -- * Inspecting @'Value's@

113 -- * Inspecting @'Value's@

125 , withObject

114 , withObject

@@ -140,16 +129,15 @@ module Data.Aeson

140 -- * Parsing

129 -- * Parsing

141 , json

130 , json

142 , json'

131 , json'

143− , parseIndexedJSON

144 ) where

132 ) where

145

133

146import Prelude.Compat

134import Prelude.Compat

147

135

148−import Data.Aeson.Types.FromJSON (ifromJSON, parseIndexedJSON)

136+import Data.Aeson.Types.FromJSON (ifromJSON)

149import Data.Aeson.Encoding (encodingToLazyByteString)

137import Data.Aeson.Encoding (encodingToLazyByteString)

150import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')

138import Data.Aeson.Parser.Internal (decodeWith, decodeStrictWith, eitherDecodeWith, eitherDecodeStrictWith, jsonEOF, json, jsonEOF', json')

151import Data.Aeson.Types

139import Data.Aeson.Types

152−import Data.Aeson.Types.Internal (JSONPath, formatError, (<?>))

140+import Data.Aeson.Types.Internal (JSONPath, formatError)

153import qualified Data.ByteString as B

141import qualified Data.ByteString as B

154import qualified Data.ByteString.Lazy as L

142import qualified Data.ByteString.Lazy as L

155

143

Data/Aeson/Compat.hsnew file+16

@@ -0,0 +1,16 @@

1+{-# LANGUAGE CPP #-}

3+module Data.Aeson.Compat

4+ (

5+ fromStrict

6+ ) where

8+import qualified Data.ByteString as S

9+import qualified Data.ByteString.Lazy as L

10+

11+fromStrict :: S.ByteString -> L.ByteString

12+#if MIN_VERSION_bytestring(0, 9, 2)

13+fromStrict = L.fromChunks . (:[])

14+#else

15+fromStrict = L.fromStrict

16+#endif

Data/Aeson/Parser.hs+1−11

@@ -35,20 +35,10 @@ module Data.Aeson.Parser

35 , value

36 , jstring

37 , scientific

38− -- ** Handling objects with duplicate keys

39− , jsonWith

40− , jsonLast

41− , jsonAccum

42− , jsonNoDup

43 -- * Strict parsers

38 -- * Strict parsers

44 -- $strict

39 -- $strict

45 , json'

40 , json'

46 , value'

41 , value'

47− -- ** Handling objects with duplicate keys

48− , jsonWith'

49− , jsonLast'

50− , jsonAccum'

51− , jsonNoDup'

52 -- * Decoding without FromJSON instances

42 -- * Decoding without FromJSON instances

53 , decodeWith

43 , decodeWith

54 , decodeStrictWith

44 , decodeStrictWith

@@ -57,7 +47,7 @@ module Data.Aeson.Parser

57 ) where

47 ) where

60−import Data.Aeson.Parser.Internal

50+import Data.Aeson.Parser.Internal (decodeStrictWith, decodeWith, eitherDecodeStrictWith, eitherDecodeWith, json, json', jstring, scientific, value, value')

62-- $lazy

52-- $lazy

63--

53--

Data/Aeson/Parser/Internal.hs+46−166

@@ -5,10 +5,6 @@

5#if MIN_VERSION_ghc_prim(0,3,1)

6{-# LANGUAGE MagicHash #-}

7#endif

8−#if __GLASGOW_HASKELL__ <= 710 && __GLASGOW_HASKELL__ >= 706

9−-- Work around a compiler bug

10−{-# OPTIONS_GHC -fsimpl-tick-factor=200 #-}

11−#endif

12-- |

8-- |

13-- Module: Data.Aeson.Parser.Internal

9-- Module: Data.Aeson.Parser.Internal

@@ -25,43 +21,29 @@ module Data.Aeson.Parser.Internal

25 (

21 (

26 -- * Lazy parsers

22 -- * Lazy parsers

27 json, jsonEOF

23 json, jsonEOF

28− , jsonWith

29− , jsonLast

30− , jsonAccum

31− , jsonNoDup

32 , value

24 , value

33 , jstring

25 , jstring

34 , jstring_

26 , jstring_

35 , scientific

27 , scientific

36 -- * Strict parsers

28 -- * Strict parsers

37 , json', jsonEOF'

29 , json', jsonEOF'

38− , jsonWith'

39− , jsonLast'

40− , jsonAccum'

41− , jsonNoDup'

42 , value'

30 , value'

43 -- * Helpers

31 -- * Helpers

44 , decodeWith

32 , decodeWith

45 , decodeStrictWith

33 , decodeStrictWith

46 , eitherDecodeWith

34 , eitherDecodeWith

47 , eitherDecodeStrictWith

35 , eitherDecodeStrictWith

48− -- ** Handling objects with duplicate keys

49− , fromListAccum

50− , parseListNoDup

51 ) where

36 ) where

53import Prelude.Compat

38import Prelude.Compat

55import Control.Applicative ((<|>))

40import Control.Applicative ((<|>))

56import Control.Monad (void, when)

41import Control.Monad (void, when)

57−import Data.Aeson.Types.Internal (IResult(..), JSONPath, Object, Result(..), Value(..))

42+import Data.Aeson.Types.Internal (IResult(..), JSONPath, Result(..), Value(..))

58import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)

43import Data.Attoparsec.ByteString.Char8 (Parser, char, decimal, endOfInput, isDigit_w8, signed, string)

59−import Data.Function (fix)

60−import Data.Functor.Compat (($>))

61import Data.Scientific (Scientific)

44import Data.Scientific (Scientific)

62import Data.Text (Text)

45import Data.Text (Text)

63−import Data.Vector (Vector)

64−import qualified Data.Vector as Vector (empty, fromList, fromListN, reverse)

46+import Data.Vector as Vector (Vector, empty, fromListN, reverse)

65import qualified Data.Attoparsec.ByteString as A

47import qualified Data.Attoparsec.ByteString as A

66import qualified Data.Attoparsec.Lazy as L

48import qualified Data.Attoparsec.Lazy as L

67import qualified Data.ByteString as B

49import qualified Data.ByteString as B

@@ -93,7 +75,7 @@ import qualified Data.Text.Encoding as TE

93#define C_n 110

75#define C_n 110

94#define C_t 116

76#define C_t 116

96−-- | Parse any JSON value.

78+-- | Parse a top-level JSON value.

97--

79--

98-- The conversion of a parsed value to a Haskell value is deferred

80-- The conversion of a parsed value to a Haskell value is deferred

99-- until the Haskell value is needed. This may improve performance if

81-- until the Haskell value is needed. This may improve performance if

@@ -103,15 +85,10 @@ import qualified Data.Text.Encoding as TE

103-- This function is an alias for 'value'. In aeson 0.8 and earlier, it

85-- This function is an alias for 'value'. In aeson 0.8 and earlier, it

104-- parsed only object or array types, in conformance with the

86-- parsed only object or array types, in conformance with the

105-- now-obsolete RFC 4627.

87-- now-obsolete RFC 4627.

106−--

107−-- ==== Warning

108−--

109−-- If an object contains duplicate keys, only the first one will be kept.

110−-- For a more flexible alternative, see 'jsonWith'.

111json :: Parser Value

88json :: Parser Value

112json = value

89json = value

113

114−-- | Parse any JSON value.

91+-- | Parse a top-level JSON value.

115--

92--

116-- This is a strict version of 'json' which avoids building up thunks

93-- This is a strict version of 'json' which avoids building up thunks

117-- during parsing; it performs all conversions immediately. Prefer

94-- during parsing; it performs all conversions immediately. Prefer

@@ -120,35 +97,23 @@ json = value

120-- This function is an alias for 'value''. In aeson 0.8 and earlier, it

97-- This function is an alias for 'value''. In aeson 0.8 and earlier, it

121-- parsed only object or array types, in conformance with the

98-- parsed only object or array types, in conformance with the

122-- now-obsolete RFC 4627.

99-- now-obsolete RFC 4627.

123−--

124−-- ==== Warning

125−--

126−-- If an object contains duplicate keys, only the first one will be kept.

127−-- For a more flexible alternative, see 'jsonWith''.

128json' :: Parser Value

100json' :: Parser Value

129json' = value'

101json' = value'

130

102

131−-- Open recursion: object_, object_', array_, array_' are parameterized by the

132−-- toplevel Value parser to be called recursively, to keep the parameter

133−-- mkObject outside of the recursive loop for proper inlining.

134−

135−object_ :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value

103+object_ :: Parser Value

136−object_ mkObject val = {-# SCC "object_" #-} Object <$> objectValues mkObject jstring val

104+object_ = {-# SCC "object_" #-} Object <$> objectValues jstring value

137−{-# INLINE object_ #-}

138

105

139−object_' :: ([(Text, Value)] -> Either String Object) -> Parser Value -> Parser Value

106+object_' :: Parser Value

140−object_' mkObject val' = {-# SCC "object_'" #-} do

107+object_' = {-# SCC "object_'" #-} do

141− !vals <- objectValues mkObject jstring' val'

108+ !vals <- objectValues jstring' value'

142 return (Object vals)

109 return (Object vals)

143 where

110 where

144 jstring' = do

111 jstring' = do

145 !s <- jstring

112 !s <- jstring

146 return s

113 return s

147−{-# INLINE object_' #-}

148

114

149−objectValues :: ([(Text, Value)] -> Either String Object)

150− -> Parser Text -> Parser Value -> Parser (H.HashMap Text Value)

115+objectValues :: Parser Text -> Parser Value -> Parser (H.HashMap Text Value)

151−objectValues mkObject str val = do

116+objectValues str val = do

152 skipSpace

117 skipSpace

153 w <- A.peekWord8'

118 w <- A.peekWord8'

154 if w == CLOSE_CURLY

119 if w == CLOSE_CURLY

@@ -158,26 +123,22 @@ objectValues mkObject str val = do

158 -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'

123 -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'

159 -- and it's much faster because it's doing in place update to the 'HashMap'!

124 -- and it's much faster because it's doing in place update to the 'HashMap'!

160 loop acc = do

125 loop acc = do

161− k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")

126+ k <- str <* skipSpace <* char ':'

162− v <- (val A.<?> "object value") <* skipSpace

127+ v <- val <* skipSpace

163− ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_CURLY) A.<?> "',' or '}'"

128+ ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY

164 let acc' = (k, v) : acc

129 let acc' = (k, v) : acc

165 if ch == COMMA

130 if ch == COMMA

166 then skipSpace >> loop acc'

131 then skipSpace >> loop acc'

167− else case mkObject acc' of

132+ else return (H.fromList acc')

168− Left err -> fail err

169− Right obj -> pure obj

170{-# INLINE objectValues #-}

133{-# INLINE objectValues #-}

171

134

172−array_ :: Parser Value -> Parser Value

135+array_ :: Parser Value

173−array_ val = {-# SCC "array_" #-} Array <$> arrayValues val

136+array_ = {-# SCC "array_" #-} Array <$> arrayValues value

174−{-# INLINE array_ #-}

175

137

176−array_' :: Parser Value -> Parser Value

138+array_' :: Parser Value

177−array_' val = {-# SCC "array_'" #-} do

139+array_' = {-# SCC "array_'" #-} do

178− !vals <- arrayValues val

140+ !vals <- arrayValues value'

179 return (Array vals)

141 return (Array vals)

180−{-# INLINE array_' #-}

181

142

182arrayValues :: Parser Value -> Parser (Vector Value)

143arrayValues :: Parser Value -> Parser (Vector Value)

183arrayValues val = do

144arrayValues val = do

@@ -188,133 +149,57 @@ arrayValues val = do

188 else loop [] 1

149 else loop [] 1

189 where

150 where

190 loop acc !len = do

151 loop acc !len = do

191− v <- (val A.<?> "json list value") <* skipSpace

152+ v <- val <* skipSpace

192− ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'"

153+ ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE

193 if ch == COMMA

154 if ch == COMMA

194 then skipSpace >> loop (v:acc) (len+1)

155 then skipSpace >> loop (v:acc) (len+1)

195 else return (Vector.reverse (Vector.fromListN len (v:acc)))

156 else return (Vector.reverse (Vector.fromListN len (v:acc)))

196{-# INLINE arrayValues #-}

157{-# INLINE arrayValues #-}

197

158

198−-- | Parse any JSON value. Synonym of 'json'.

159+-- | Parse any JSON value. You should usually 'json' in preference to

199−value :: Parser Value

160+-- this function, as this function relaxes the object-or-array

200−value = jsonWith (pure . H.fromList)

161+-- requirement of RFC 4627.

201−

202−-- | Parse any JSON value.

203−--

204−-- This parser is parameterized by a function to construct an 'Object'

205−-- from a raw list of key-value pairs, where duplicates are preserved.

206−-- The pairs appear in __reverse order__ from the source.

207−--

208−-- ==== __Examples__

209−--

210−-- 'json' keeps only the first occurence of each key, using 'HashMap.Lazy.fromList'.

211−--

212−-- @

213−-- 'json' = 'jsonWith' ('Right' '.' 'H.fromList')

214−-- @

215−--

216−-- 'jsonLast' keeps the last occurence of each key, using

217−-- @'HashMap.Lazy.fromListWith' ('const' 'id')@.

218−--

219−-- @

220−-- 'jsonLast' = 'jsonWith' ('Right' '.' 'HashMap.Lazy.fromListWith' ('const' 'id'))

221−-- @

222−--

223−-- 'jsonAccum' keeps wraps all values in arrays to keep duplicates, using

224−-- 'fromListAccum'.

225--

162--

226−-- @

163+-- In particular, be careful in using this function if you think your

227−-- 'jsonAccum' = 'jsonWith' ('Right' . 'fromListAccum')

164+-- code might interoperate with Javascript. A naïve Javascript

228−-- @

165+-- library that parses JSON data using @eval@ is vulnerable to attack

229−--

166+-- unless the encoded data represents an object or an array. JSON

230−-- 'jsonNoDup' fails if any object contains duplicate keys, using 'parseListNoDup'.

167+-- implementations in other languages conform to that same restriction

231−--

168+-- to preserve interoperability and security.

232−-- @

169+value :: Parser Value

233−-- 'jsonNoDup' = 'jsonWith' 'parseListNoDup'

170+value = do

234−-- @

235−jsonWith :: ([(Text, Value)] -> Either String Object) -> Parser Value

236−jsonWith mkObject = fix $ \value_ -> do

237 skipSpace

171 skipSpace

238 w <- A.peekWord8'

172 w <- A.peekWord8'

239 case w of

173 case w of

240 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)

174 DOUBLE_QUOTE -> A.anyWord8 *> (String <$> jstring_)

241− OPEN_CURLY -> A.anyWord8 *> object_ mkObject value_

175+ OPEN_CURLY -> A.anyWord8 *> object_

242− OPEN_SQUARE -> A.anyWord8 *> array_ value_

176+ OPEN_SQUARE -> A.anyWord8 *> array_

243− C_f -> string "false" $> Bool False

177+ C_f -> string "false" *> pure (Bool False)

244− C_t -> string "true" $> Bool True

178+ C_t -> string "true" *> pure (Bool True)

245− C_n -> string "null" $> Null

179+ C_n -> string "null" *> pure Null

246 _ | w >= 48 && w <= 57 || w == 45

180 _ | w >= 48 && w <= 57 || w == 45

247 -> Number <$> scientific

181 -> Number <$> scientific

248 | otherwise -> fail "not a valid json value"

182 | otherwise -> fail "not a valid json value"

249−{-# INLINE jsonWith #-}

250−

251−-- | Variant of 'json' which keeps only the last occurence of every key.

252−jsonLast :: Parser Value

253−jsonLast = jsonWith (Right . H.fromListWith (const id))

254−

255−-- | Variant of 'json' wrapping all object mappings in 'Array' to preserve

256−-- key-value pairs with the same keys.

257−jsonAccum :: Parser Value

258−jsonAccum = jsonWith (Right . fromListAccum)

259−

260−-- | Variant of 'json' which fails if any object contains duplicate keys.

261−jsonNoDup :: Parser Value

262−jsonNoDup = jsonWith parseListNoDup

263−

264−-- | @'fromListAccum' kvs@ is an object mapping keys to arrays containing all

265−-- associated values from the original list @kvs@.

266−--

267−-- >>> fromListAccum [("apple", Bool True), ("apple", Bool False), ("orange", Bool False)]

268−-- fromList [("apple", [Bool False, Bool True]), ("orange", [Bool False])]

269−fromListAccum :: [(Text, Value)] -> Object

270−fromListAccum =

271− fmap (Array . Vector.fromList . ($ [])) . H.fromListWith (.) . (fmap . fmap) (:)

272−

273−-- | @'fromListNoDup' kvs@ fails if @kvs@ contains duplicate keys.

274−parseListNoDup :: [(Text, Value)] -> Either String Object

275−parseListNoDup =

276− H.traverseWithKey unwrap . H.fromListWith (\_ _ -> Nothing) . (fmap . fmap) Just

277− where

278− unwrap k Nothing = Left $ "found duplicate key: " ++ show k

279− unwrap _ (Just v) = Right v

280

183

281−-- | Strict version of 'value'. Synonym of 'json''.

184+-- | Strict version of 'value'. See also 'json''.

282value' :: Parser Value

185value' :: Parser Value

283−value' = jsonWith' (pure . H.fromList)

186+value' = do

284−

285−-- | Strict version of 'jsonWith'.

286−jsonWith' :: ([(Text, Value)] -> Either String Object) -> Parser Value

287−jsonWith' mkObject = fix $ \value_ -> do

288 skipSpace

187 skipSpace

289 w <- A.peekWord8'

188 w <- A.peekWord8'

290 case w of

189 case w of

291 DOUBLE_QUOTE -> do

190 DOUBLE_QUOTE -> do

292 !s <- A.anyWord8 *> jstring_

191 !s <- A.anyWord8 *> jstring_

293 return (String s)

192 return (String s)

294− OPEN_CURLY -> A.anyWord8 *> object_' mkObject value_

193+ OPEN_CURLY -> A.anyWord8 *> object_'

295− OPEN_SQUARE -> A.anyWord8 *> array_' value_

194+ OPEN_SQUARE -> A.anyWord8 *> array_'

296− C_f -> string "false" $> Bool False

195+ C_f -> string "false" *> pure (Bool False)

297− C_t -> string "true" $> Bool True

196+ C_t -> string "true" *> pure (Bool True)

298− C_n -> string "null" $> Null

197+ C_n -> string "null" *> pure Null

299 _ | w >= 48 && w <= 57 || w == 45

198 _ | w >= 48 && w <= 57 || w == 45

300 -> do

199 -> do

301 !n <- scientific

200 !n <- scientific

302 return (Number n)

201 return (Number n)

303 | otherwise -> fail "not a valid json value"

202 | otherwise -> fail "not a valid json value"

304−{-# INLINE jsonWith' #-}

305−

306−-- | Variant of 'json'' which keeps only the last occurence of every key.

307−jsonLast' :: Parser Value

308−jsonLast' = jsonWith' (pure . H.fromListWith (const id))

309−

310−-- | Variant of 'json'' wrapping all object mappings in 'Array' to preserve

311−-- key-value pairs with the same keys.

312−jsonAccum' :: Parser Value

313−jsonAccum' = jsonWith' (pure . fromListAccum)

314−

315−-- | Variant of 'json'' which fails if any object contains duplicate keys.

316−jsonNoDup' :: Parser Value

317−jsonNoDup' = jsonWith' parseListNoDup

318

203

319-- | Parse a quoted JSON string.

204-- | Parse a quoted JSON string.

320jstring :: Parser Text

205jstring :: Parser Text

@@ -390,12 +275,7 @@ eitherDecodeWith p to s =

390 L.Done _ v -> case to v of

275 L.Done _ v -> case to v of

391 ISuccess a -> Right a

276 ISuccess a -> Right a

392 IError path msg -> Left (path, msg)

277 IError path msg -> Left (path, msg)

393− L.Fail _ ctx msg -> Left ([], buildMsg ctx msg)

278+ L.Fail _ _ msg -> Left ([], msg)

394− where

395− buildMsg :: [String] -> String -> String

396− buildMsg [] msg = msg

397− buildMsg (expectation:_) msg =

398− msg ++ ". Expecting " ++ expectation

399{-# INLINE eitherDecodeWith #-}

279{-# INLINE eitherDecodeWith #-}

400

280

401eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

281eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

Data/Aeson/TH.hs+60−52

@@ -135,15 +135,22 @@ import Data.Map (Map)

135import Data.Maybe (catMaybes, fromMaybe, mapMaybe)

136import qualified Data.Monoid as Monoid

137import Data.Set (Set)

138+#if MIN_VERSION_template_haskell(2,8,0)

138import Language.Haskell.TH hiding (Arity)

139import Language.Haskell.TH hiding (Arity)

140+#else

141+import Language.Haskell.TH

142+#endif

139import Language.Haskell.TH.Datatype

143import Language.Haskell.TH.Datatype

144+#if MIN_VERSION_template_haskell(2,7,0) && !(MIN_VERSION_template_haskell(2,8,0))

145+import Language.Haskell.TH.Lib (starK)

146+#endif

140#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))

147#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))

141import Language.Haskell.TH.Syntax (mkNameG_tc)

148import Language.Haskell.TH.Syntax (mkNameG_tc)

142#endif

149#endif

143import Text.Printf (printf)

150import Text.Printf (printf)

144import qualified Data.Aeson.Encoding.Internal as E

151import qualified Data.Aeson.Encoding.Internal as E

145import qualified Data.Foldable as F (all)

152import qualified Data.Foldable as F (all)

146−import qualified Data.HashMap.Strict as H (difference, fromList, keys, lookup, toList)

153+import qualified Data.HashMap.Strict as H (lookup, toList)

147import qualified Data.List.NonEmpty as NE (length, reverse)

154import qualified Data.List.NonEmpty as NE (length, reverse)

148import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

155import qualified Data.Map as M (fromList, keys, lookup , singleton, size)

149import qualified Data.Semigroup as Semigroup (Option(..))

156import qualified Data.Semigroup as Semigroup (Option(..))

@@ -152,6 +159,8 @@ import qualified Data.Text as T (Text, pack, unpack)

152import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)

159import qualified Data.Vector as V (unsafeIndex, null, length, create, empty)

153import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)

160import qualified Data.Vector.Mutable as VM (unsafeNew, unsafeWrite)

154

161

162+{-# ANN module "Hlint: ignore Reduce duplication" #-}

163+

155--------------------------------------------------------------------------------

164--------------------------------------------------------------------------------

156-- Convenience

165-- Convenience

157--------------------------------------------------------------------------------

166--------------------------------------------------------------------------------

@@ -325,13 +334,13 @@ consToValue :: ToJSONFun

325consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "

334consToValue _ _ _ _ [] = error $ "Data.Aeson.TH.consToValue: "

326 ++ "Not a single constructor given!"

335 ++ "Not a single constructor given!"

327

336

328−consToValue target jc opts instTys cons = do

337+consToValue target jc opts vars cons = do

329 value <- newName "value"

338 value <- newName "value"

330 tjs <- newNameList "_tj" $ arityInt jc

339 tjs <- newNameList "_tj" $ arityInt jc

331 tjls <- newNameList "_tjl" $ arityInt jc

340 tjls <- newNameList "_tjl" $ arityInt jc

332 let zippedTJs = zip tjs tjls

341 let zippedTJs = zip tjs tjls

333 interleavedTJs = interleave tjs tjls

342 interleavedTJs = interleave tjs tjls

334− lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys

343+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars

335 tvMap = M.fromList $ zip lastTyVars zippedTJs

344 tvMap = M.fromList $ zip lastTyVars zippedTJs

336 lamE (map varP $ interleavedTJs ++ [value]) $

345 lamE (map varP $ interleavedTJs ++ [value]) $

337 caseE (varE value) (matches tvMap)

346 caseE (varE value) (matches tvMap)

@@ -663,13 +672,13 @@ consFromJSON :: JSONClass

663consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

672consFromJSON _ _ _ _ [] = error $ "Data.Aeson.TH.consFromJSON: "

664 ++ "Not a single constructor given!"

673 ++ "Not a single constructor given!"

665

674

666−consFromJSON jc tName opts instTys cons = do

675+consFromJSON jc tName opts vars cons = do

667 value <- newName "value"

676 value <- newName "value"

668 pjs <- newNameList "_pj" $ arityInt jc

677 pjs <- newNameList "_pj" $ arityInt jc

669 pjls <- newNameList "_pjl" $ arityInt jc

678 pjls <- newNameList "_pjl" $ arityInt jc

670 let zippedPJs = zip pjs pjls

679 let zippedPJs = zip pjs pjls

671 interleavedPJs = interleave pjs pjls

680 interleavedPJs = interleave pjs pjls

672− lastTyVars = map varTToName $ drop (length instTys - arityInt jc) instTys

681+ lastTyVars = map varTToName $ drop (length vars - arityInt jc) vars

673 tvMap = M.fromList $ zip lastTyVars zippedPJs

682 tvMap = M.fromList $ zip lastTyVars zippedPJs

674 lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap

683 lamE (map varP $ interleavedPJs ++ [value]) $ lamExpr value tvMap

675

684

@@ -922,32 +931,12 @@ parseRecord :: JSONClass

922 -> Name

931 -> Name

923 -> [Name]

932 -> [Name]

924 -> Name

933 -> Name

925− -> Bool

926 -> ExpQ

934 -> ExpQ

927−parseRecord jc tvMap argTys opts tName conName fields obj inTaggedObject =

935+parseRecord jc tvMap argTys opts tName conName fields obj =

928− (if rejectUnknownFields opts

929− then infixApp checkUnknownRecords [|(>>)|]

930− else id) $

931 foldl' (\a b -> infixApp a [|(<*>)|] b)

936 foldl' (\a b -> infixApp a [|(<*>)|] b)

932 (infixApp (conE conName) [|(<$>)|] x)

937 (infixApp (conE conName) [|(<$>)|] x)

933 xs

938 xs

934 where

939 where

935− tagFieldNameAppender =

936− if inTaggedObject then (tagFieldName (sumEncoding opts) :) else id

937− knownFields = appE [|H.fromList|] $ listE $

938− map (\knownName -> tupE [appE [|T.pack|] $ litE $ stringL knownName, [|()|]]) $

939− tagFieldNameAppender $ map nameBase fields

940− checkUnknownRecords =

941− caseE (appE [|H.keys|] $ infixApp (varE obj) [|H.difference|] knownFields)

942− [ match (listP []) (normalB [|return ()|]) []

943− , newName "unknownFields" >>=

944− \unknownFields -> match (varP unknownFields)

945− (normalB $ appE [|fail|] $ infixApp

946− (litE (stringL "Unknown fields: "))

947− [|(++)|]

948− (appE [|show|] (varE unknownFields)))

949− []

950− ]

951 x:xs = [ [|lookupField|]

940 x:xs = [ [|lookupField|]

952 `appE` dispatchParseJSON jc conName tvMap argTy

941 `appE` dispatchParseJSON jc conName tvMap argTy

953 `appE` litE (stringL $ show tName)

942 `appE` litE (stringL $ show tName)

@@ -1022,7 +1011,7 @@ parseArgs jc tvMap tName opts

1022 , constructorFields = argTys }

1011 , constructorFields = argTys }

1023 (Left (_, obj)) = do

1012 (Left (_, obj)) = do

1024 argTys' <- mapM resolveTypeSynonyms argTys

1013 argTys' <- mapM resolveTypeSynonyms argTys

1025− parseRecord jc tvMap argTys' opts tName conName fields obj True

1014+ parseRecord jc tvMap argTys' opts tName conName fields obj

1026parseArgs jc tvMap tName opts

1015parseArgs jc tvMap tName opts

1027 info@ConstructorInfo { constructorName = conName

1016 info@ConstructorInfo { constructorName = conName

1028 , constructorVariant = RecordConstructor fields

1017 , constructorVariant = RecordConstructor fields

@@ -1037,7 +1026,7 @@ parseArgs jc tvMap tName opts

1037 argTys' <- mapM resolveTypeSynonyms argTys

1026 argTys' <- mapM resolveTypeSynonyms argTys

1038 caseE (varE valName)

1027 caseE (varE valName)

1039 [ match (conP 'Object [varP obj]) (normalB $

1028 [ match (conP 'Object [varP obj]) (normalB $

1040− parseRecord jc tvMap argTys' opts tName conName fields obj False) []

1029+ parseRecord jc tvMap argTys' opts tName conName fields obj) []

1041 , matchFailed tName conName "Object"

1030 , matchFailed tName conName "Object"

1042 ]

1031 ]

1043

1032

@@ -1220,27 +1209,23 @@ deriveJSONClass :: [(JSONFun, JSONClass -> Name -> Options -> [Type]

1220deriveJSONClass consFuns jc opts name = do

1209deriveJSONClass consFuns jc opts name = do

1221 info <- reifyDatatype name

1210 info <- reifyDatatype name

1222 case info of

1211 case info of

1223− DatatypeInfo { datatypeContext = ctxt

1212+ DatatypeInfo { datatypeContext = ctxt

1224− , datatypeName = parentName

1213+ , datatypeName = parentName

1225−#if MIN_VERSION_th_abstraction(0,3,0)

1226− , datatypeInstTypes = instTys

1227−#else

1228− , datatypeVars = instTys

1214+ , datatypeVars = vars

1229−#endif

1230− , datatypeVariant = variant

1215+ , datatypeVariant = variant

1231− , datatypeCons = cons

1216+ , datatypeCons = cons

1232 } -> do

1217 } -> do

1233 (instanceCxt, instanceType)

1218 (instanceCxt, instanceType)

1234− <- buildTypeInstance parentName jc ctxt instTys variant

1219+ <- buildTypeInstance parentName jc ctxt vars variant

1235 (:[]) <$> instanceD (return instanceCxt)

1220 (:[]) <$> instanceD (return instanceCxt)

1236 (return instanceType)

1221 (return instanceType)

1237− (methodDecs parentName instTys cons)

1222+ (methodDecs parentName vars cons)

1238 where

1223 where

1239 methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]

1224 methodDecs :: Name -> [Type] -> [ConstructorInfo] -> [Q Dec]

1240− methodDecs parentName instTys cons = flip map consFuns $ \(jf, jfMaker) ->

1225+ methodDecs parentName vars cons = flip map consFuns $ \(jf, jfMaker) ->

1241 funD (jsonFunValName jf (arity jc))

1226 funD (jsonFunValName jf (arity jc))

1242 [ clause []

1227 [ clause []

1243− (normalB $ jfMaker jc parentName opts instTys cons)

1228+ (normalB $ jfMaker jc parentName opts vars cons)

1244 []

1229 []

1245 ]

1230 ]

1246

1231

@@ -1256,21 +1241,17 @@ mkFunCommon :: (JSONClass -> Name -> Options -> [Type] -> [ConstructorInfo] -> Q

1256mkFunCommon consFun jc opts name = do

1241mkFunCommon consFun jc opts name = do

1257 info <- reifyDatatype name

1242 info <- reifyDatatype name

1258 case info of

1243 case info of

1259− DatatypeInfo { datatypeContext = ctxt

1244+ DatatypeInfo { datatypeContext = ctxt

1260− , datatypeName = parentName

1245+ , datatypeName = parentName

1261−#if MIN_VERSION_th_abstraction(0,3,0)

1262− , datatypeInstTypes = instTys

1263−#else

1264− , datatypeVars = instTys

1246+ , datatypeVars = vars

1265−#endif

1266− , datatypeVariant = variant

1247+ , datatypeVariant = variant

1267− , datatypeCons = cons

1248+ , datatypeCons = cons

1268 } -> do

1249 } -> do

1269 -- We force buildTypeInstance here since it performs some checks for whether

1250 -- We force buildTypeInstance here since it performs some checks for whether

1270 -- or not the provided datatype's kind matches the derived method's

1251 -- or not the provided datatype's kind matches the derived method's

1271 -- typeclass, and produces errors if it can't.

1252 -- typeclass, and produces errors if it can't.

1272− !_ <- buildTypeInstance parentName jc ctxt instTys variant

1253+ !_ <- buildTypeInstance parentName jc ctxt vars variant

1273− consFun jc parentName opts instTys cons

1254+ consFun jc parentName opts vars cons

1274

1255

1275dispatchFunByType :: JSONClass

1256dispatchFunByType :: JSONClass

1276 -> JSONFun

1257 -> JSONFun

@@ -1603,13 +1584,21 @@ type TyVarMap = Map Name (Name, Name)

1603-- | Returns True if a Type has kind *.

1584-- | Returns True if a Type has kind *.

1604hasKindStar :: Type -> Bool

1585hasKindStar :: Type -> Bool

1605hasKindStar VarT{} = True

1586hasKindStar VarT{} = True

1587+#if MIN_VERSION_template_haskell(2,8,0)

1606hasKindStar (SigT _ StarT) = True

1588hasKindStar (SigT _ StarT) = True

1589+#else

1590+hasKindStar (SigT _ StarK) = True

1591+#endif

1607hasKindStar _ = False

1592hasKindStar _ = False

1608

1593

1609-- Returns True is a kind is equal to *, or if it is a kind variable.

1594-- Returns True is a kind is equal to *, or if it is a kind variable.

1610isStarOrVar :: Kind -> Bool

1595isStarOrVar :: Kind -> Bool

1596+#if MIN_VERSION_template_haskell(2,8,0)

1611isStarOrVar StarT = True

1597isStarOrVar StarT = True

1612isStarOrVar VarT{} = True

1598isStarOrVar VarT{} = True

1599+#else

1600+isStarOrVar StarK = True

1601+#endif

1613isStarOrVar _ = False

1602isStarOrVar _ = False

1614

1603

1615-- Generate a list of fresh names with a common prefix, and numbered suffixes.

1604-- Generate a list of fresh names with a common prefix, and numbered suffixes.

@@ -1667,7 +1656,9 @@ isTyFamily (ConT n) = do

1667#else

1656#else

1668 FamilyI (FamilyD TypeFam _ _ _) _ -> True

1657 FamilyI (FamilyD TypeFam _ _ _) _ -> True

1669#endif

1658#endif

1659+#if MIN_VERSION_template_haskell(2,9,0)

1670 FamilyI ClosedTypeFamilyD{} _ -> True

1660 FamilyI ClosedTypeFamilyD{} _ -> True

1661+#endif

1671 _ -> False

1662 _ -> False

1672isTyFamily _ = return False

1663isTyFamily _ = return False

1673

1664

@@ -1695,7 +1686,9 @@ mentionsName = go

1695 go :: Type -> [Name] -> Bool

1686 go :: Type -> [Name] -> Bool

1696 go (AppT t1 t2) names = go t1 names || go t2 names

1687 go (AppT t1 t2) names = go t1 names || go t2 names

1697 go (SigT t _k) names = go t names

1688 go (SigT t _k) names = go t names

1689+#if MIN_VERSION_template_haskell(2,8,0)

1698 || go _k names

1690 || go _k names

1691+#endif

1699 go (VarT n) names = n `elem` names

1692 go (VarT n) names = n `elem` names

1700 go _ _ = False

1693 go _ _ = False

1701

1694

@@ -1751,14 +1744,23 @@ uncurryTy t = ([], t :| [])

1751

1744

1752-- | Like uncurryType, except on a kind level.

1745-- | Like uncurryType, except on a kind level.

1753uncurryKind :: Kind -> NonEmpty Kind

1746uncurryKind :: Kind -> NonEmpty Kind

1747+#if MIN_VERSION_template_haskell(2,8,0)

1754uncurryKind = snd . uncurryTy

1748uncurryKind = snd . uncurryTy

1749+#else

1750+uncurryKind (ArrowK k1 k2) = k1 <| uncurryKind k2

1751+uncurryKind k = k :| []

1752+#endif

1755

1753

1756createKindChain :: Int -> Kind

1754createKindChain :: Int -> Kind

1757createKindChain = go starK

1755createKindChain = go starK

1758 where

1756 where

1759 go :: Kind -> Int -> Kind

1757 go :: Kind -> Int -> Kind

1760 go k 0 = k

1758 go k 0 = k

1759+#if MIN_VERSION_template_haskell(2,8,0)

1761 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)

1760 go k !n = go (AppT (AppT ArrowT StarT) k) (n - 1)

1761+#else

1762+ go k !n = go (ArrowK StarK k) (n - 1)

1763+#endif

1762

1764

1763-- | Makes a string literal expression from a constructor's name.

1765-- | Makes a string literal expression from a constructor's name.

1764conNameExp :: Options -> ConstructorInfo -> Q Exp

1766conNameExp :: Options -> ConstructorInfo -> Q Exp

@@ -1812,7 +1814,11 @@ canEtaReduce remaining dropped =

1812-------------------------------------------------------------------------------

1814-------------------------------------------------------------------------------

1813

1815

1814applySubstitutionKind :: Map Name Kind -> Type -> Type

1816applySubstitutionKind :: Map Name Kind -> Type -> Type

1817+#if MIN_VERSION_template_haskell(2,8,0)

1815applySubstitutionKind = applySubstitution

1818applySubstitutionKind = applySubstitution

1819+#else

1820+applySubstitutionKind _ t = t

1821+#endif

1816

1822

1817substNameWithKind :: Name -> Kind -> Type -> Type

1823substNameWithKind :: Name -> Kind -> Type -> Type

1818substNameWithKind n k = applySubstitutionKind (M.singleton n k)

1824substNameWithKind n k = applySubstitutionKind (M.singleton n k)

@@ -1976,7 +1982,9 @@ data StarKindStatus = NotKindStar

1976canRealizeKindStar :: Type -> StarKindStatus

1982canRealizeKindStar :: Type -> StarKindStatus

1977canRealizeKindStar t = case t of

1983canRealizeKindStar t = case t of

1978 _ | hasKindStar t -> KindStar

1984 _ | hasKindStar t -> KindStar

1985+#if MIN_VERSION_template_haskell(2,8,0)

1979 SigT _ (VarT k) -> IsKindVar k

1986 SigT _ (VarT k) -> IsKindVar k

1987+#endif

1980 _ -> NotKindStar

1988 _ -> NotKindStar

1981

1989

1982-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.

1990-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists.

Data/Aeson/Types.hs−19

@@ -53,12 +53,6 @@ module Data.Aeson.Types

53 , coerceFromJSONKeyFunction

54 , mapFromJSONKeyFunction

56− -- *** Generic keys

57− , GToJSONKey()

58− , genericToJSONKey

59− , GFromJSONKey()

60− , genericFromJSONKey

61−

62 -- ** Liftings to unary and binary type constructors

56 -- ** Liftings to unary and binary type constructors

63 , FromJSON1(..)

57 , FromJSON1(..)

64 , parseJSON1

58 , parseJSON1

@@ -124,7 +118,6 @@ module Data.Aeson.Types

124 , sumEncoding

118 , sumEncoding

125 , unwrapUnaryRecords

119 , unwrapUnaryRecords

126 , tagSingleConstructors

120 , tagSingleConstructors

127− , rejectUnknownFields

128

121

129 -- ** Options utilities

122 -- ** Options utilities

130 , SumEncoding(..)

123 , SumEncoding(..)

@@ -132,18 +125,6 @@ module Data.Aeson.Types

132 , camelTo2

125 , camelTo2

133 , defaultOptions

126 , defaultOptions

134 , defaultTaggedObject

127 , defaultTaggedObject

135−

136− -- ** Options for object keys

137− , JSONKeyOptions

138− , keyModifier

139− , defaultJSONKeyOptions

140−

141− -- * Parsing context

142− , (<?>)

143− , JSONPath

144− , JSONPathElement(..)

145− , formatPath

146− , formatRelativePath

147 ) where

128 ) where

148

129

149import Prelude.Compat

130import Prelude.Compat

Data/Aeson/Types/Class.hs+1−5

@@ -6,6 +6,7 @@

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE NoImplicitPrelude #-}

8{-# LANGUAGE ScopedTypeVariables #-}

9+{-# LANGUAGE TypeSynonymInstances #-}

10-- |

11-- |

11-- Module: Data.Aeson.Types.Class

12-- Module: Data.Aeson.Types.Class

@@ -58,11 +59,6 @@ module Data.Aeson.Types.Class

58 , fromJSONKeyCoerce

59 , fromJSONKeyCoerce

59 , coerceFromJSONKeyFunction

60 , coerceFromJSONKeyFunction

60 , mapFromJSONKeyFunction

61 , mapFromJSONKeyFunction

61− -- ** Generic keys

62− , GToJSONKey()

63− , genericToJSONKey

64− , GFromJSONKey()

65− , genericFromJSONKey

66 -- * Object key-value pairs

62 -- * Object key-value pairs

67 , KeyValue(..)

63 , KeyValue(..)

Data/Aeson/Types/FromJSON.hs+266−523

@@ -5,16 +5,20 @@

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE GADTs #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE NamedFieldPuns #-}

8{-# LANGUAGE NoImplicitPrelude #-}

9{-# LANGUAGE NoImplicitPrelude #-}

9{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE OverloadedStrings #-}

10−{-# LANGUAGE PolyKinds #-}

11{-# LANGUAGE RecordWildCards #-}

12{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE TypeOperators #-}

14−{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TypeSynonymInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

16{-# LANGUAGE ViewPatterns #-}

18+#if __GLASGOW_HASKELL__ >= 706

19+{-# LANGUAGE PolyKinds #-}

20+#endif

21+

18#include "incoherent-compat.h"

22#include "incoherent-compat.h"

19#include "overlapping-compat.h"

23#include "overlapping-compat.h"

@@ -42,9 +46,6 @@ module Data.Aeson.Types.FromJSON

42 , coerceFromJSONKeyFunction

46 , coerceFromJSONKeyFunction

43 , mapFromJSONKeyFunction

47 , mapFromJSONKeyFunction

45− , GFromJSONKey()

46− , genericFromJSONKey

47−

48 -- * List functions

49 -- * List functions

49 , listParser

50 , listParser

@@ -67,7 +68,6 @@ module Data.Aeson.Types.FromJSON

67 , explicitParseField

68 , explicitParseField

68 , explicitParseFieldMaybe

69 , explicitParseFieldMaybe

69 , explicitParseFieldMaybe'

70 , explicitParseFieldMaybe'

70− , parseIndexedJSON

71 -- ** Operators

72 , (.:)

73 , (.:?)

@@ -80,14 +80,14 @@ module Data.Aeson.Types.FromJSON

81import Prelude.Compat

83−import Control.Applicative ((<|>), Const(..), liftA2)

83+import Control.Applicative ((<|>), Const(..))

84−import Control.Monad (zipWithM)

84+import Control.Monad ((<=<), zipWithM)

85import Data.Aeson.Internal.Functions (mapKey)

86import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)

87import Data.Aeson.Types.Generic

88import Data.Aeson.Types.Internal

89import Data.Bits (unsafeShiftR)

90−import Data.Fixed (Fixed, HasResolution (resolution), Nano)

90+import Data.Fixed (Fixed, HasResolution)

91import Data.Functor.Compose (Compose(..))

92import Data.Functor.Identity (Identity(..))

93import Data.Functor.Product (Product(..))

@@ -103,10 +103,8 @@ import Data.Scientific (Scientific, base10Exponent)

103import Data.Tagged (Tagged(..))

104import Data.Text (Text, pack, unpack)

105import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

106−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))

106+import Data.Time.Format (parseTime)

107−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))

108−import Data.Time.Clock.System.Compat (SystemTime (..))

109−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)

107+import Data.Time.Locale.Compat (defaultTimeLocale)

110import Data.Traversable as Tr (sequence)

108import Data.Traversable as Tr (sequence)

111import Data.Vector (Vector)

109import Data.Vector (Vector)

112import Data.Version (Version, parseVersion)

110import Data.Version (Version, parseVersion)

@@ -118,9 +116,9 @@ import GHC.Generics

118import Numeric.Natural (Natural)

116import Numeric.Natural (Natural)

119import Text.ParserCombinators.ReadP (readP_to_S)

117import Text.ParserCombinators.ReadP (readP_to_S)

120import Unsafe.Coerce (unsafeCoerce)

118import Unsafe.Coerce (unsafeCoerce)

119+import qualified Data.Aeson.Compat as Compat

121import qualified Data.Aeson.Parser.Time as Time

120import qualified Data.Aeson.Parser.Time as Time

122import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)

121import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)

123−import qualified Data.ByteString.Lazy as L

124import qualified Data.DList as DList

122import qualified Data.DList as DList

125import qualified Data.HashMap.Strict as H

123import qualified Data.HashMap.Strict as H

126import qualified Data.HashSet as HashSet

124import qualified Data.HashSet as HashSet

@@ -149,14 +147,22 @@ import qualified Data.Primitive.SmallArray as PM

149import qualified Data.Primitive.Types as PM

147import qualified Data.Primitive.Types as PM

150

148

151#if MIN_VERSION_primitive(0,6,4)

149#if MIN_VERSION_primitive(0,6,4)

152−#if !MIN_VERSION_primitive(0,7,0)

153import qualified Data.Primitive.UnliftedArray as PM

150import qualified Data.Primitive.UnliftedArray as PM

154−#endif

155import qualified Data.Primitive.PrimArray as PM

151import qualified Data.Primitive.PrimArray as PM

156#endif

152#endif

157

153

154+#ifndef HAS_COERCIBLE

155+#define HAS_COERCIBLE (__GLASGOW_HASKELL__ >= 707)

156+#endif

158

157

158+#if HAS_COERCIBLE

159import Data.Coerce (Coercible, coerce)

160+coerce' :: Coercible a b => a -> b

161+coerce' = coerce

162+#else

163+coerce' :: a -> b

164+coerce' = unsafeCoerce

165+#endif

160

166

161parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

167parseIndexedJSON :: (Value -> Parser a) -> Int -> Value -> Parser a

162parseIndexedJSON p idx value = p value <?> Index idx

168parseIndexedJSON p idx value = p value <?> Index idx

@@ -287,21 +293,14 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

287--

293--

288-- The basic ways to signal a failed conversion are as follows:

294-- The basic ways to signal a failed conversion are as follows:

289--

295--

290−-- * 'fail' yields a custom error message: it is the recommended way of

296+-- * 'empty' and 'mzero' work, but are terse and uninformative;

291−-- reporting a failure;

292--

297--

293−-- * 'Control.Applicative.empty' (or 'Control.Monad.mzero') is uninformative:

298+-- * 'fail' yields a custom error message;

294−-- use it when the error is meant to be caught by some @('<|>')@;

295--

299--

296−-- * 'typeMismatch' can be used to report a failure when the encountered value

300+-- * 'typeMismatch' produces an informative message for cases when the

297−-- is not of the expected JSON type; 'unexpected' is an appropriate alternative

301+-- value encountered is not of the expected type.

298−-- when more than one type may be expected, or to keep the expected type

299−-- implicit.

300--

302--

301−-- 'prependFailure' (or 'modifyFailure') add more information to a parser's

302−-- error messages.

303−--

304−-- An example type and instance using 'typeMismatch' and 'prependFailure':

303+-- An example type and instance using 'typeMismatch':

305--

304--

306-- @

305-- @

307-- \-- Allow ourselves to write 'Text' literals.

306-- \-- Allow ourselves to write 'Text' literals.

@@ -315,11 +314,9 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

315-- '<*>' v '.:' \"y\"

314-- '<*>' v '.:' \"y\"

316--

315--

317-- \-- We do not expect a non-'Object' value here.

316-- \-- We do not expect a non-'Object' value here.

318−-- \-- We could use 'Control.Applicative.empty' to fail, but 'typeMismatch'

317+-- \-- We could use 'mzero' to fail, but 'typeMismatch'

319-- \-- gives a much more informative error message.

318-- \-- gives a much more informative error message.

320−-- 'parseJSON' invalid =

319+-- 'parseJSON' invalid = 'typeMismatch' \"Coord\" invalid

321−-- 'prependFailure' "parsing Coord failed, "

322−-- ('typeMismatch' \"Object\" invalid)

323-- @

320-- @

324--

321--

325-- For this common case of only being concerned with a single

322-- For this common case of only being concerned with a single

@@ -362,7 +359,7 @@ genericLiftParseJSON opts pj pjl = fmap to1 . gParseJSON opts (From1Args pj pjl)

362-- @

359-- @

363--

360--

364-- The default implementation will be equivalent to

361-- The default implementation will be equivalent to

365−-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; if you need different

362+-- @parseJSON = 'genericParseJSON' 'defaultOptions'@; If you need different

366-- options, you can customize the generic decoding by defining:

363-- options, you can customize the generic decoding by defining:

367--

364--

368-- @

365-- @

@@ -396,16 +393,6 @@ class FromJSON a where

396-- > newtype SomeId = SomeId { getSomeId :: Text }

393-- > newtype SomeId = SomeId { getSomeId :: Text }

397-- > deriving (Eq,Ord,Hashable,FromJSONKey)

394-- > deriving (Eq,Ord,Hashable,FromJSONKey)

398--

395--

399−-- If you have a sum of nullary constructors, you may use the generic

400−-- implementation:

401−--

402−-- @

403−-- data Color = Red | Green | Blue

404−-- deriving Generic

405−--

406−-- instance 'FromJSONKey' Color where

407−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'

408−-- @

409class FromJSONKey a where

396class FromJSONKey a where

410 -- | Strategy for parsing the key of a map-like container.

397 -- | Strategy for parsing the key of a map-like container.

411 fromJSONKey :: FromJSONKeyFunction a

398 fromJSONKey :: FromJSONKeyFunction a

@@ -428,7 +415,11 @@ class FromJSONKey a where

428-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'

415-- At the moment this type is intentionally not exported. 'FromJSONKeyFunction'

429-- can be inspected, but cannot be constructed.

416-- can be inspected, but cannot be constructed.

430data CoerceText a where

417data CoerceText a where

418+#if HAS_COERCIBLE

431 CoerceText :: Coercible Text a => CoerceText a

419 CoerceText :: Coercible Text a => CoerceText a

420+#else

421+ CoerceText :: CoerceText a

422+#endif

432

423

433-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the

424-- | This type is related to 'ToJSONKeyFunction'. If 'FromJSONKeyValue' is used in the

434-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'

425-- 'FromJSONKey' instance, then 'ToJSONKeyValue' should be used in the 'ToJSONKey'

@@ -448,7 +439,7 @@ data FromJSONKeyFunction a

448

439

449-- | Only law abiding up to interpretation

440-- | Only law abiding up to interpretation

450instance Functor FromJSONKeyFunction where

441instance Functor FromJSONKeyFunction where

451− fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce)

442+ fmap h (FromJSONKeyCoerce CoerceText) = FromJSONKeyText (h . coerce')

452 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

443 fmap h (FromJSONKeyText f) = FromJSONKeyText (h . f)

453 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

444 fmap h (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap h . f)

454 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

445 fmap h (FromJSONKeyValue f) = FromJSONKeyValue (fmap h . f)

@@ -462,7 +453,9 @@ instance Functor FromJSONKeyFunction where

462--

453--

463-- On pre GHC 7.8 this is unconstrainted function.

454-- On pre GHC 7.8 this is unconstrainted function.

464fromJSONKeyCoerce ::

455fromJSONKeyCoerce ::

456+#if HAS_COERCIBLE

465 Coercible Text a =>

457 Coercible Text a =>

458+#endif

466 FromJSONKeyFunction a

459 FromJSONKeyFunction a

467fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

460fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

468

461

@@ -470,52 +463,34 @@ fromJSONKeyCoerce = FromJSONKeyCoerce CoerceText

470--

463--

471-- See note on 'fromJSONKeyCoerce'.

464-- See note on 'fromJSONKeyCoerce'.

472coerceFromJSONKeyFunction ::

465coerceFromJSONKeyFunction ::

466+#if HAS_COERCIBLE

473 Coercible a b =>

467 Coercible a b =>

468+#endif

474 FromJSONKeyFunction a -> FromJSONKeyFunction b

469 FromJSONKeyFunction a -> FromJSONKeyFunction b

470+#if HAS_COERCIBLE

475coerceFromJSONKeyFunction = coerce

471coerceFromJSONKeyFunction = coerce

472+#else

473+coerceFromJSONKeyFunction (FromJSONKeyCoerce CoerceText) = FromJSONKeyCoerce CoerceText

474+coerceFromJSONKeyFunction (FromJSONKeyText f) = FromJSONKeyText (coerce' . f)

475+coerceFromJSONKeyFunction (FromJSONKeyTextParser f) = FromJSONKeyTextParser (fmap coerce' . f)

476+coerceFromJSONKeyFunction (FromJSONKeyValue f) = FromJSONKeyValue (fmap coerce' . f)

477+#endif

476

478

477{-# RULES

479{-# RULES

478 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

480 "FromJSONKeyCoerce: fmap id" forall (x :: FromJSONKeyFunction a).

479 fmap id x = x

481 fmap id x = x

480 #-}

482 #-}

483+#if HAS_COERCIBLE

481{-# RULES

484{-# RULES

482 "FromJSONKeyCoerce: fmap coerce" forall x .

485 "FromJSONKeyCoerce: fmap coerce" forall x .

483 fmap coerce x = coerceFromJSONKeyFunction x

486 fmap coerce x = coerceFromJSONKeyFunction x

484 #-}

487 #-}

488+#endif

485

489

486-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

490-- | Same as 'fmap'. Provided for the consistency with 'ToJSONKeyFunction'.

487mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

491mapFromJSONKeyFunction :: (a -> b) -> FromJSONKeyFunction a -> FromJSONKeyFunction b

488mapFromJSONKeyFunction = fmap

492mapFromJSONKeyFunction = fmap

489

493

490−-- | 'fromJSONKey' for 'Generic' types.

491−-- These types must be sums of nullary constructors, whose names will be used

492−-- as keys for JSON objects.

493−--

494−-- See also 'genericToJSONKey'.

495−--

496−-- === __Example__

497−--

498−-- @

499−-- data Color = Red | Green | Blue

500−-- deriving 'Generic'

501−--

502−-- instance 'FromJSONKey' Color where

503−-- 'fromJSONKey' = 'genericFromJSONKey' 'defaultJSONKeyOptions'

504−-- @

505−genericFromJSONKey :: forall a. (Generic a, GFromJSONKey (Rep a))

506− => JSONKeyOptions

507− -> FromJSONKeyFunction a

508−genericFromJSONKey opts = FromJSONKeyTextParser $ \t ->

509− case parseSumFromString (keyModifier opts) t of

510− Nothing -> fail $

511− "invalid key " ++ show t ++ ", expected one of " ++ show cnames

512− Just k -> pure (to k)

513− where

514− cnames = unTagged2 (constructorTags (keyModifier opts) :: Tagged2 (Rep a) [String])

515−

516−class (ConstructorNames f, SumFromString f) => GFromJSONKey f where

517−instance (ConstructorNames f, SumFromString f) => GFromJSONKey f where

518−

519-------------------------------------------------------------------------------

494-------------------------------------------------------------------------------

520-- Functions needed for documentation

495-- Functions needed for documentation

521-------------------------------------------------------------------------------

496-------------------------------------------------------------------------------

@@ -768,13 +743,13 @@ withBoundedScientific' f v = withBoundedScientific_ id f v

768-- | A variant of 'withBoundedScientific_' parameterized by a function to apply

743-- | A variant of 'withBoundedScientific_' parameterized by a function to apply

769-- to the 'Parser' in case of failure.

744-- to the 'Parser' in case of failure.

770withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a

745withBoundedScientific_ :: (Parser a -> Parser a) -> (Scientific -> Parser a) -> Value -> Parser a

771−withBoundedScientific_ whenFail f (Number scientific) =

746+withBoundedScientific_ whenFail f v@(Number scientific) =

772− if exp10 > 1024

747+ if exponent > 1024

773 then whenFail (fail msg)

748 then whenFail (fail msg)

774 else f scientific

749 else f scientific

775 where

750 where

776− exp10 = base10Exponent scientific

751+ exponent = base10Exponent scientific

777− msg = "found a number with exponent " ++ show exp10 ++ ", but it must not be greater than 1024"

752+ msg = "found a number with exponent " ++ show exponent ++ ", but it must not be greater than 1024"

778withBoundedScientific_ whenFail _ v =

753withBoundedScientific_ whenFail _ v =

779 whenFail (typeMismatch "Number" v)

754 whenFail (typeMismatch "Number" v)

780{-# INLINE withBoundedScientific_ #-}

755{-# INLINE withBoundedScientific_ #-}

@@ -794,7 +769,7 @@ withBool name _ v = prependContext name (typeMismatch "Boolean" v)

794-- | Decode a nested JSON-encoded string.

769-- | Decode a nested JSON-encoded string.

795withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a

770withEmbeddedJSON :: String -> (Value -> Parser a) -> Value -> Parser a

796withEmbeddedJSON _ innerParser (String txt) =

771withEmbeddedJSON _ innerParser (String txt) =

797− either fail innerParser $ eitherDecode (L.fromStrict $ T.encodeUtf8 txt)

772+ either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)

798 where

773 where

799 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON

774 eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON

800 eitherFormatError = either (Left . uncurry formatError) Right

775 eitherFormatError = either (Left . uncurry formatError) Right

@@ -863,7 +838,7 @@ parseFieldMaybe' = (.:!)

863-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@

838-- E.g. @'explicitParseField' 'parseJSON1' :: ('FromJSON1' f, 'FromJSON' a) -> 'Object' -> 'Text' -> 'Parser' (f a)@

864explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a

839explicitParseField :: (Value -> Parser a) -> Object -> Text -> Parser a

865explicitParseField p obj key = case H.lookup key obj of

840explicitParseField p obj key = case H.lookup key obj of

866− Nothing -> fail $ "key " ++ show key ++ " not found"

841+ Nothing -> fail $ "key " ++ show key ++ " not present"

867 Just v -> p v <?> Key key

842 Just v -> p v <?> Key key

868{-# INLINE explicitParseField #-}

843{-# INLINE explicitParseField #-}

869

844

@@ -913,37 +888,6 @@ instance OVERLAPPABLE_ (GFromJSON arity a) => GFromJSON arity (M1 i c a) where

913 -- parsed value:

888 -- parsed value:

914 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs

889 gParseJSON opts fargs = fmap M1 . gParseJSON opts fargs

915

890

916−-- Information for error messages

917−

918−type TypeName = String

919−type ConName = String

920−

921−-- | Add the name of the type being parsed to a parser's error messages.

922−contextType :: TypeName -> Parser a -> Parser a

923−contextType = prependContext

924−

925−-- | Add the tagKey that will be looked up while building an ADT

926−-- | Produce the error equivalent to

927−-- | Left "Error in $: parsing T failed, expected an object with keys "tag" and

928−-- | "contents", where "tag" i-- |s associated to one of ["Foo", "Bar"],

929−-- | The parser returned error was: could not find key "tag"

930−contextTag :: Text -> [String] -> Parser a -> Parser a

931−contextTag tagKey cnames = prependFailure

932− ("expected Object with key \"" ++ unpack tagKey ++ "\"" ++

933− " containing one of " ++ show cnames ++ ", ")

934−

935−-- | Add the name of the constructor being parsed to a parser's error messages.

936−contextCons :: ConName -> TypeName -> Parser a -> Parser a

937−contextCons cname tname = prependContext (showCons cname tname)

938−

939−-- | Render a constructor as @\"MyType(MyConstructor)\"@.

940−showCons :: ConName -> TypeName -> String

941−showCons cname tname = tname ++ "(" ++ cname ++ ")"

942−

943−--------------------------------------------------------------------------------

944−

945−-- Parsing single fields

946−

947instance (FromJSON a) => GFromJSON arity (K1 i a) where

891instance (FromJSON a) => GFromJSON arity (K1 i a) where

948 -- Constant values are decoded using their FromJSON instance:

892 -- Constant values are decoded using their FromJSON instance:

949 gParseJSON _opts _ = fmap K1 . parseJSON

893 gParseJSON _opts _ = fmap K1 . parseJSON

@@ -958,499 +902,342 @@ instance (FromJSON1 f) => GFromJSON One (Rec1 f) where

958 -- FromJSON1 instance:

902 -- FromJSON1 instance:

959 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl

903 gParseJSON _opts (From1Args pj pjl) = fmap Rec1 . liftParseJSON pj pjl

960

904

961−instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where

905+instance GFromJSON arity U1 where

962− -- If an occurrence of the last type parameter is nested inside two

906+ -- Empty constructors are expected to be encoded as an empty array:

963− -- composed types, it is decoded by using the outermost type's FromJSON1

964− -- instance to generically decode the innermost type:

965− gParseJSON opts fargs =

907+ gParseJSON _opts _ v

966− let gpj = gParseJSON opts fargs in

908+ | isEmptyArray v = pure U1

967− fmap Comp1 . liftParseJSON gpj (listParser gpj)

909+ | otherwise = typeMismatch "unit constructor (U1)" v

968−

969−--------------------------------------------------------------------------------

970−

971−instance (GFromJSON' arity a, Datatype d) => GFromJSON arity (D1 d a) where

972− -- Meta-information, which is not handled elsewhere, is just added to the

973− -- parsed value:

974− gParseJSON opts fargs = fmap M1 . gParseJSON' (tname :* opts :* fargs)

975− where

976− tname = moduleName proxy ++ "." ++ datatypeName proxy

977− proxy = undefined :: M1 _i d _f _p

978−

979−-- | 'GFromJSON', after unwrapping the 'D1' constructor, now carrying the data

980−-- type's name.

981−class GFromJSON' arity f where

982− gParseJSON' :: TypeName :* Options :* FromArgs arity a

983− -> Value

984− -> Parser (f a)

985

910

986−-- | Single constructor.

987instance ( ConsFromJSON arity a

911instance ( ConsFromJSON arity a

988 , AllNullary (C1 c a) allNullary

912 , AllNullary (C1 c a) allNullary

989 , ParseSum arity (C1 c a) allNullary

913 , ParseSum arity (C1 c a) allNullary

990− , Constructor c

991− ) => GFromJSON' arity (C1 c a) where

914+ ) => GFromJSON arity (D1 d (C1 c a)) where

992 -- The option 'tagSingleConstructors' determines whether to wrap

915 -- The option 'tagSingleConstructors' determines whether to wrap

993 -- a single-constructor type.

916 -- a single-constructor type.

994− gParseJSON' p@(_ :* opts :* _)

917+ gParseJSON opts fargs

995 | tagSingleConstructors opts

918 | tagSingleConstructors opts

919+ = fmap M1

996− = (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))

920+ . (unTagged :: Tagged allNullary (Parser (C1 c a p)) -> Parser (C1 c a p))

997− . parseSum p

921+ . parseSum opts fargs

998− | otherwise = fmap M1 . consParseJSON (cname :* p)

922+ | otherwise = fmap M1 . fmap M1 . consParseJSON opts fargs

999− where

923+

1000− cname = conName (undefined :: M1 _i c _f _p)

924+instance (ConsFromJSON arity a) => GFromJSON arity (C1 c a) where

1001−

925+ -- Constructors need to be decoded differently depending on whether they're

1002−-- | Multiple constructors.

926+ -- a record or not. This distinction is made by consParseJSON:

927+ gParseJSON opts fargs = fmap M1 . consParseJSON opts fargs

928+

929+instance ( FromProduct arity a, FromProduct arity b

930+ , ProductSize a, ProductSize b

931+ ) => GFromJSON arity (a :*: b) where

932+ -- Products are expected to be encoded to an array. Here we check whether we

933+ -- got an array of the same size as the product, then parse each of the

934+ -- product's elements using parseProduct:

935+ gParseJSON opts fargs = withArray "product (:*:)" $ \arr ->

936+ let lenArray = V.length arr

937+ lenProduct = (unTagged2 :: Tagged2 (a :*: b) Int -> Int)

938+ productSize in

939+ if lenArray == lenProduct

940+ then parseProduct opts fargs arr 0 lenProduct

941+ else fail $ "When expecting a product of " ++ show lenProduct ++

942+ " values, encountered an Array of " ++ show lenArray ++

943+ " elements instead"

944+

1003−instance ( AllNullary (a :+: b) allNullary

945+instance ( AllNullary (a :+: b) allNullary

1004− , ParseSum arity (a :+: b) allNullary

946+ , ParseSum arity (a :+: b) allNullary

1005− ) => GFromJSON' arity (a :+: b) where

947+ ) => GFromJSON arity (a :+: b) where

1006 -- If all constructors of a sum datatype are nullary and the

948 -- If all constructors of a sum datatype are nullary and the

1007 -- 'allNullaryToStringTag' option is set they are expected to be

949 -- 'allNullaryToStringTag' option is set they are expected to be

1008 -- encoded as strings. This distinction is made by 'parseSum':

950 -- encoded as strings. This distinction is made by 'parseSum':

1009− gParseJSON' p =

951+ gParseJSON opts fargs =

1010− (unTagged :: Tagged allNullary (Parser ((a :+: b) _d)) ->

952+ (unTagged :: Tagged allNullary (Parser ((a :+: b) d)) ->

1011− Parser ((a :+: b) _d))

953+ Parser ((a :+: b) d))

1012− . parseSum p

954+ . parseSum opts fargs

955+

956+instance (FromJSON1 f, GFromJSON One g) => GFromJSON One (f :.: g) where

957+ -- If an occurrence of the last type parameter is nested inside two

958+ -- composed types, it is decoded by using the outermost type's FromJSON1

959+ -- instance to generically decode the innermost type:

960+ gParseJSON opts fargs =

961+ let gpj = gParseJSON opts fargs in

962+ fmap Comp1 . liftParseJSON gpj (listParser gpj)

1013

963

1014--------------------------------------------------------------------------------

964--------------------------------------------------------------------------------

1015

965

1016class ParseSum arity f allNullary where

966class ParseSum arity f allNullary where

1017− parseSum :: TypeName :* Options :* FromArgs arity a

967+ parseSum :: Options -> FromArgs arity a

1018− -> Value

1019− -> Tagged allNullary (Parser (f a))

968+ -> Value -> Tagged allNullary (Parser (f a))

1020

969

1021−instance ( ConstructorNames f

1022− , SumFromString f

970+instance ( SumFromString f

1023 , FromPair arity f

971 , FromPair arity f

1024 , FromTaggedObject arity f

972 , FromTaggedObject arity f

1025 , FromUntaggedValue arity f

973 , FromUntaggedValue arity f

1026 ) => ParseSum arity f True where

974 ) => ParseSum arity f True where

1027− parseSum p@(tname :* opts :* _)

975+ parseSum opts fargs

1028− | allNullaryToStringTag opts = Tagged . parseAllNullarySum tname opts

976+ | allNullaryToStringTag opts = Tagged . parseAllNullarySum opts

1029− | otherwise = Tagged . parseNonAllNullarySum p

977+ | otherwise = Tagged . parseNonAllNullarySum opts fargs

1030

978

1031−instance ( ConstructorNames f

1032− , FromPair arity f

979+instance ( FromPair arity f

1033 , FromTaggedObject arity f

980 , FromTaggedObject arity f

1034 , FromUntaggedValue arity f

981 , FromUntaggedValue arity f

1035 ) => ParseSum arity f False where

982 ) => ParseSum arity f False where

1036− parseSum p = Tagged . parseNonAllNullarySum p

983+ parseSum opts fargs = Tagged . parseNonAllNullarySum opts fargs

1037

984

1038--------------------------------------------------------------------------------

985--------------------------------------------------------------------------------

1039

986

1040−parseAllNullarySum :: (SumFromString f, ConstructorNames f)

987+parseAllNullarySum :: SumFromString f => Options -> Value -> Parser (f a)

1041− => TypeName -> Options -> Value -> Parser (f a)

1042−parseAllNullarySum tname opts =

988+parseAllNullarySum opts = withText "Text" $ \key ->

1043− withText tname $ \tag ->

1044− maybe (badTag tag) return $

989+ maybe (notFound key) return $

1045− parseSumFromString modifier tag

990+ parseSumFromString opts key

1046− where

1047− badTag tag = failWithCTags tname modifier $ \cnames ->

1048− "expected one of the tags " ++ show cnames ++

1049− ", but found tag " ++ show tag

1050− modifier = constructorTagModifier opts

1051−

1052−-- | Fail with an informative error message about a mismatched tag.

1053−-- The error message is parameterized by the list of expected tags,

1054−-- to be inferred from the result type of the parser.

1055−failWithCTags

1056− :: forall f a t. ConstructorNames f

1057− => TypeName -> (String -> t) -> ([t] -> String) -> Parser (f a)

1058−failWithCTags tname modifier f =

1059− contextType tname . fail $ f cnames

1060− where

1061− cnames = unTagged2 (constructorTags modifier :: Tagged2 f [t])

1062

991

1063class SumFromString f where

992class SumFromString f where

1064− parseSumFromString :: (String -> String) -> Text -> Maybe (f a)

993+ parseSumFromString :: Options -> Text -> Maybe (f a)

1065

994

1066instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

995instance (SumFromString a, SumFromString b) => SumFromString (a :+: b) where

1067 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

996 parseSumFromString opts key = (L1 <$> parseSumFromString opts key) <|>

1068 (R1 <$> parseSumFromString opts key)

997 (R1 <$> parseSumFromString opts key)

1069

998

1070instance (Constructor c) => SumFromString (C1 c U1) where

999instance (Constructor c) => SumFromString (C1 c U1) where

1071− parseSumFromString modifier key

1000+ parseSumFromString opts key | key == name = Just $ M1 U1

1072− | key == name = Just $ M1 U1

1073− | otherwise = Nothing

1001+ | otherwise = Nothing

1074− where

1002+ where

1075− name = pack $ modifier $ conName (undefined :: M1 _i c _f _p)

1003+ name = pack $ constructorTagModifier opts $

1076−

1077−-- For genericFromJSONKey

1078−instance SumFromString a => SumFromString (D1 d a) where

1079− parseSumFromString modifier key = M1 <$> parseSumFromString modifier key

1080−

1081−-- | List of all constructor tags.

1082−constructorTags :: ConstructorNames a => (String -> t) -> Tagged2 a [t]

1083−constructorTags modifier =

1084− fmap DList.toList (constructorNames' modifier)

1085−

1086−-- | List of all constructor names of an ADT, after a given conversion

1087−-- function. (Better inlining.)

1088−class ConstructorNames a where

1089− constructorNames' :: (String -> t) -> Tagged2 a (DList.DList t)

1090−

1091−instance (ConstructorNames a, ConstructorNames b) => ConstructorNames (a :+: b) where

1092− constructorNames' = liftA2 append constructorNames' constructorNames'

1093− where

1094− append

1095− :: Tagged2 a (DList.DList t)

1096− -> Tagged2 b (DList.DList t)

1097− -> Tagged2 (a :+: b) (DList.DList t)

1098− append (Tagged2 xs) (Tagged2 ys) = Tagged2 (DList.append xs ys)

1099−

1100−instance Constructor c => ConstructorNames (C1 c a) where

1101− constructorNames' f = Tagged2 (pure (f cname))

1102− where

1103− cname = conName (undefined :: M1 _i c _f _p)

1004+ conName (undefined :: t c U1 p)

1104−

1105−-- For genericFromJSONKey

1106−instance ConstructorNames a => ConstructorNames (D1 d a) where

1107− constructorNames' = retag . constructorNames'

1108− where

1109− retag :: Tagged2 a u -> Tagged2 (D1 d a) u

1110− retag (Tagged2 x) = Tagged2 x

1111

1005

1112--------------------------------------------------------------------------------

1006--------------------------------------------------------------------------------

1007+

1113−parseNonAllNullarySum :: forall f c arity.

1008+parseNonAllNullarySum :: ( FromPair arity f

1114− ( FromPair arity f

1115 , FromTaggedObject arity f

1009 , FromTaggedObject arity f

1116 , FromUntaggedValue arity f

1010 , FromUntaggedValue arity f

1117− , ConstructorNames f

1118− ) => TypeName :* Options :* FromArgs arity c

1011+ ) => Options -> FromArgs arity c

1119 -> Value -> Parser (f c)

1012 -> Value -> Parser (f c)

1120−parseNonAllNullarySum p@(tname :* opts :* _) =

1013+parseNonAllNullarySum opts fargs =

1121 case sumEncoding opts of

1014 case sumEncoding opts of

1122 TaggedObject{..} ->

1015 TaggedObject{..} ->

1123− withObject tname $ \obj -> do

1016+ withObject "Object" $ \obj -> do

1124− tag <- contextType tname . contextTag tagKey cnames_ $ obj .: tagKey

1125− fromMaybe (badTag tag <?> Key tagKey) $

1126− parseFromTaggedObject (tag :* contentsFieldName :* p) obj

1127− where

1128− tagKey = pack tagFieldName

1017+ tag <- obj .: pack tagFieldName

1129− badTag tag = failWith_ $ \cnames ->

1018+ fromMaybe (notFound tag) $

1130− "expected tag field to be one of " ++ show cnames ++

1019+ parseFromTaggedObject opts fargs contentsFieldName obj tag

1131− ", but found tag " ++ show tag

1132− cnames_ = unTagged2 (constructorTags (constructorTagModifier opts) :: Tagged2 f [String])

1133

1020

1134 ObjectWithSingleField ->

1021 ObjectWithSingleField ->

1022+ withObject "Object" $ \obj ->

1135− withObject tname $ \obj -> case H.toList obj of

1023+ case H.toList obj of

1136− [(tag, v)] -> maybe (badTag tag) (<?> Key tag) $

1024+ [pair@(tag, _)] -> fromMaybe (notFound tag) $

1137− parsePair (tag :* p) v

1025+ parsePair opts fargs pair

1138− _ -> contextType tname . fail $

1026+ _ -> fail "Object doesn't have a single field"

1139− "expected an Object with a single pair, but found " ++

1140− show (H.size obj) ++ " pairs"

1141− where

1142− badTag tag = failWith_ $ \cnames ->

1143− "expected an Object with a single pair where the tag is one of " ++

1144− show cnames ++ ", but found tag " ++ show tag

1145

1027

1146 TwoElemArray ->

1028 TwoElemArray ->

1147− withArray tname $ \arr -> case V.length arr of

1029+ withArray "Array" $ \arr ->

1030+ if V.length arr == 2

1148− 2 | String tag <- V.unsafeIndex arr 0 ->

1031+ then case V.unsafeIndex arr 0 of

1149− maybe (badTag tag <?> Index 0) (<?> Index 1) $

1032+ String tag -> fromMaybe (notFound tag) $

1150− parsePair (tag :* p) (V.unsafeIndex arr 1)

1033+ parsePair opts fargs (tag, V.unsafeIndex arr 1)

1151− | otherwise ->

1152− contextType tname $

1153− fail "tag element is not a String" <?> Index 0

1034+ _ -> fail "First element is not a String"

1154− len -> contextType tname . fail $

1035+ else fail "Array doesn't have 2 elements"

1155− "expected a 2-element Array, but encountered an Array of length " ++

1156− show len

1157− where

1158− badTag tag = failWith_ $ \cnames ->

1159− "expected tag of the 2-element Array to be one of " ++

1160− show cnames ++ ", but found tag " ++ show tag

1161

1036

1162− UntaggedValue -> parseUntaggedValue p

1037+ UntaggedValue -> parseUntaggedValue opts fargs

1163− where

1164− failWith_ = failWithCTags tname (constructorTagModifier opts)

1165

1038

1166--------------------------------------------------------------------------------

1039--------------------------------------------------------------------------------

1167

1040

1168class FromTaggedObject arity f where

1041class FromTaggedObject arity f where

1169− -- The first two components of the parameter tuple are: the constructor tag

1170− -- to match against, and the contents field name.

1171− parseFromTaggedObject

1042+ parseFromTaggedObject :: Options -> FromArgs arity a

1172− :: Text :* String :* TypeName :* Options :* FromArgs arity a

1173− -> Object

1043+ -> String -> Object

1174− -> Maybe (Parser (f a))

1044+ -> Text -> Maybe (Parser (f a))

1175

1045

1176instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>

1046instance ( FromTaggedObject arity a, FromTaggedObject arity b) =>

1177 FromTaggedObject arity (a :+: b) where

1047 FromTaggedObject arity (a :+: b) where

1178− parseFromTaggedObject p obj =

1048+ parseFromTaggedObject opts fargs contentsFieldName obj tag =

1179− (fmap L1 <$> parseFromTaggedObject p obj) <|>

1049+ (fmap L1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag) <|>

1180− (fmap R1 <$> parseFromTaggedObject p obj)

1050+ (fmap R1 <$> parseFromTaggedObject opts fargs contentsFieldName obj tag)

1181

1051

1182−instance ( IsRecord f isRecord

1183− , FromTaggedObject' arity f isRecord

1052+instance ( FromTaggedObject' arity f

1184 , Constructor c

1053 , Constructor c

1185 ) => FromTaggedObject arity (C1 c f) where

1054 ) => FromTaggedObject arity (C1 c f) where

1186− parseFromTaggedObject (tag :* contentsFieldName :* p@(_ :* opts :* _))

1055+ parseFromTaggedObject opts fargs contentsFieldName obj tag

1187− | tag == tag'

1188− = Just . fmap M1 .

1189− (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .

1190− parseFromTaggedObject' (contentsFieldName :* cname :* p)

1056+ | tag == name = Just $ M1 <$> parseFromTaggedObject'

1057+ opts fargs contentsFieldName obj

1191− | otherwise = const Nothing

1058+ | otherwise = Nothing

1192− where

1059+ where

1193− tag' = pack $ constructorTagModifier opts cname

1060+ name = pack $ constructorTagModifier opts $

1194− cname = conName (undefined :: M1 _i c _f _p)

1061+ conName (undefined :: t c f p)

1195

1062

1196--------------------------------------------------------------------------------

1063--------------------------------------------------------------------------------

1197

1064

1198−class FromTaggedObject' arity f isRecord where

1065+class FromTaggedObject' arity f where

1199− -- The first component of the parameter tuple is the contents field name.

1066+ parseFromTaggedObject' :: Options -> FromArgs arity a -> String

1200− parseFromTaggedObject'

1067+ -> Object -> Parser (f a)

1068+

1069+class FromTaggedObject'' arity f isRecord where

1201− :: String :* ConName :* TypeName :* Options :* FromArgs arity a

1070+ parseFromTaggedObject'' :: Options -> FromArgs arity a -> String

1202− -> Object -> Tagged isRecord (Parser (f a))

1071+ -> Object -> Tagged isRecord (Parser (f a))

1203−

1072+

1073+instance ( IsRecord f isRecord

1074+ , FromTaggedObject'' arity f isRecord

1204−instance (RecordFromJSON arity f, FieldNames f) => FromTaggedObject' arity f True where

1075+ ) => FromTaggedObject' arity f where

1205− -- Records are unpacked in the tagged object

1076+ parseFromTaggedObject' opts fargs contentsFieldName =

1206− parseFromTaggedObject' (_ :* p) = Tagged . recordParseJSON (True :* p)

1077+ (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a)) .

1207−

1078+ parseFromTaggedObject'' opts fargs contentsFieldName

1079+

1208−instance (ConsFromJSON arity f) => FromTaggedObject' arity f False where

1080+instance (FromRecord arity f) => FromTaggedObject'' arity f True where

1209− -- Nonnullary nonrecords are encoded in the contents field

1210− parseFromTaggedObject' p obj = Tagged $ do

1081+ parseFromTaggedObject'' opts fargs _ =

1211− contents <- contextCons cname tname (obj .: key)

1082+ Tagged . parseRecord opts fargs

1212− consParseJSON p' contents <?> Key key

1213− where

1214− key = pack contentsFieldName

1215− contentsFieldName :* p'@(cname :* tname :* _) = p

1216

1083

1084+instance (GFromJSON arity f) => FromTaggedObject'' arity f False where

1085+ parseFromTaggedObject'' opts fargs contentsFieldName = Tagged .

1086+ (gParseJSON opts fargs <=< (.: pack contentsFieldName))

1087+

1217−instance OVERLAPPING_ FromTaggedObject' arity U1 False where

1088+instance OVERLAPPING_ FromTaggedObject'' arity U1 False where

1218− -- Nullary constructors don't need a contents field

1089+ parseFromTaggedObject'' _ _ _ _ = Tagged (pure U1)

1219− parseFromTaggedObject' _ _ = Tagged (pure U1)

1220

1090

1221--------------------------------------------------------------------------------

1091--------------------------------------------------------------------------------

1222

1092

1223−-- | Constructors need to be decoded differently depending on whether they're

1224−-- a record or not. This distinction is made by 'ConsParseJSON'.

1225class ConsFromJSON arity f where

1093class ConsFromJSON arity f where

1226− consParseJSON

1227− :: ConName :* TypeName :* Options :* FromArgs arity a

1094+ consParseJSON :: Options -> FromArgs arity a

1228− -> Value -> Parser (f a)

1095+ -> Value -> Parser (f a)

1229

1096

1230class ConsFromJSON' arity f isRecord where

1097class ConsFromJSON' arity f isRecord where

1231− consParseJSON'

1232− :: ConName :* TypeName :* Options :* FromArgs arity a

1098+ consParseJSON' :: Options -> FromArgs arity a

1233− -> Value -> Tagged isRecord (Parser (f a))

1099+ -> Value -> Tagged isRecord (Parser (f a))

1234

1100

1235instance ( IsRecord f isRecord

1101instance ( IsRecord f isRecord

1236 , ConsFromJSON' arity f isRecord

1102 , ConsFromJSON' arity f isRecord

1237 ) => ConsFromJSON arity f where

1103 ) => ConsFromJSON arity f where

1238− consParseJSON p =

1104+ consParseJSON opts fargs =

1239 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

1105 (unTagged :: Tagged isRecord (Parser (f a)) -> Parser (f a))

1240− . consParseJSON' p

1106+ . consParseJSON' opts fargs

1241

1107

1242instance OVERLAPPING_

1108instance OVERLAPPING_

1243− ( GFromJSON arity a, RecordFromJSON arity (S1 s a)

1109+ ( GFromJSON arity a, FromRecord arity (S1 s a)

1244 ) => ConsFromJSON' arity (S1 s a) True where

1110 ) => ConsFromJSON' arity (S1 s a) True where

1245− consParseJSON' p@(cname :* tname :* opts :* fargs)

1111+ consParseJSON' opts fargs

1246− | unwrapUnaryRecords opts = Tagged . fmap M1 . gParseJSON opts fargs

1112+ | unwrapUnaryRecords opts = Tagged . gParseJSON opts fargs

1247− | otherwise = Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))

1113+ | otherwise = Tagged . withObject "unary record" (parseRecord opts fargs)

1248−

1249−instance RecordFromJSON arity f => ConsFromJSON' arity f True where

1250− consParseJSON' p@(cname :* tname :* _) =

1251− Tagged . withObject (showCons cname tname) (recordParseJSON (False :* p))

1252

1114

1253−instance OVERLAPPING_

1254− ConsFromJSON' arity U1 False where

1255− -- Empty constructors are expected to be encoded as an empty array:

1256− consParseJSON' (cname :* tname :* _) v =

1257− Tagged . contextCons cname tname $ case v of

1258− Array a | V.null a -> pure U1

1259− | otherwise -> fail_ a

1260− _ -> typeMismatch "Array" v

1261− where

1262− fail_ a = fail $

1263− "expected an empty Array, but encountered an Array of length " ++

1264− show (V.length a)

1265−

1266−instance OVERLAPPING_

1267− GFromJSON arity f => ConsFromJSON' arity (S1 s f) False where

1115+instance FromRecord arity f => ConsFromJSON' arity f True where

1268− consParseJSON' (_ :* _ :* opts :* fargs) =

1116+ consParseJSON' opts fargs =

1269− Tagged . fmap M1 . gParseJSON opts fargs

1117+ Tagged . withObject "record (:*:)" (parseRecord opts fargs)

1270

1118

1271−instance (ProductFromJSON arity f, ProductSize f

1272− ) => ConsFromJSON' arity f False where

1119+instance GFromJSON arity f => ConsFromJSON' arity f False where

1273− consParseJSON' p = Tagged . productParseJSON0 p

1120+ consParseJSON' opts fargs = Tagged . gParseJSON opts fargs

1274

1121

1275--------------------------------------------------------------------------------

1122--------------------------------------------------------------------------------

1276

1123

1277−class FieldNames f where

1124+class FromRecord arity f where

1278− fieldNames :: f a -> [Text] -> [Text]

1125+ parseRecord :: Options -> FromArgs arity a

1126+ -> Object -> Parser (f a)

1279

1127

1280−instance (FieldNames a, FieldNames b) => FieldNames (a :*: b) where

1128+instance ( FromRecord arity a

1281− fieldNames _ =

1129+ , FromRecord arity b

1282− fieldNames (undefined :: a x) .

1283− fieldNames (undefined :: b y)

1284−

1285−instance (Selector s) => FieldNames (S1 s f) where

1286− fieldNames _ = (pack (selName (undefined :: M1 _i s _f _p)) :)

1287−

1288−class RecordFromJSON arity f where

1289− recordParseJSON

1290− :: Bool :* ConName :* TypeName :* Options :* FromArgs arity a

1291− -> Object -> Parser (f a)

1292−

1293−instance ( FieldNames f

1294− , RecordFromJSON' arity f

1295− ) => RecordFromJSON arity f where

1296− recordParseJSON (fromTaggedSum :* p@(cname :* tname :* opts :* _)) =

1297− \obj -> checkUnknown obj >> recordParseJSON' p obj

1298− where

1299− knownFields :: H.HashMap Text ()

1300− knownFields = H.fromList $ map (,()) $

1301− fieldNames (undefined :: f a)

1302− [pack (tagFieldName (sumEncoding opts)) | fromTaggedSum]

1303− checkUnknown =

1304− if not (rejectUnknownFields opts)

1305− then \_ -> return ()

1306− else \obj -> case H.keys (H.difference obj knownFields) of

1307− [] -> return ()

1308− unknownFields -> contextCons cname tname $

1309− fail ("unknown fields: " ++ show unknownFields)

1310−

1311−class RecordFromJSON' arity f where

1312− recordParseJSON'

1313− :: ConName :* TypeName :* Options :* FromArgs arity a

1314− -> Object -> Parser (f a)

1315−

1316−instance ( RecordFromJSON' arity a

1317− , RecordFromJSON' arity b

1318− ) => RecordFromJSON' arity (a :*: b) where

1130+ ) => FromRecord arity (a :*: b) where

1319− recordParseJSON' p obj =

1131+ parseRecord opts fargs obj =

1320− (:*:) <$> recordParseJSON' p obj

1132+ (:*:) <$> parseRecord opts fargs obj

1321− <*> recordParseJSON' p obj

1133+ <*> parseRecord opts fargs obj

1322

1134

1323instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1135instance OVERLAPPABLE_ (Selector s, GFromJSON arity a) =>

1324− RecordFromJSON' arity (S1 s a) where

1136+ FromRecord arity (S1 s a) where

1325− recordParseJSON' (cname :* tname :* opts :* fargs) obj = do

1137+ parseRecord opts fargs =

1326− fv <- contextCons cname tname (obj .: label)

1138+ (<?> Key label) . gParseJSON opts fargs <=< (.: label)

1327− M1 <$> gParseJSON opts fargs fv <?> Key label

1328− where

1139+ where

1329− label = pack $ fieldLabelModifier opts sname

1140+ label = pack . fieldLabelModifier opts $ selName (undefined :: t s a p)

1330− sname = selName (undefined :: M1 _i s _f _p)

1331

1141

1332instance INCOHERENT_ (Selector s, FromJSON a) =>

1142instance INCOHERENT_ (Selector s, FromJSON a) =>

1333− RecordFromJSON' arity (S1 s (K1 i (Maybe a))) where

1143+ FromRecord arity (S1 s (K1 i (Maybe a))) where

1334− recordParseJSON' (_ :* _ :* opts :* _) obj = M1 . K1 <$> obj .:? pack label

1144+ parseRecord opts _ obj = M1 . K1 <$> obj .:? pack label

1335− where

1145+ where

1336− label = fieldLabelModifier opts sname

1146+ label = fieldLabelModifier opts $

1337− sname = selName (undefined :: M1 _i s _f _p)

1147+ selName (undefined :: t s (K1 i (Maybe a)) p)

1338

1148

1339-- Parse an Option like a Maybe.

1149-- Parse an Option like a Maybe.

1340instance INCOHERENT_ (Selector s, FromJSON a) =>

1150instance INCOHERENT_ (Selector s, FromJSON a) =>

1341− RecordFromJSON' arity (S1 s (K1 i (Semigroup.Option a))) where

1151+ FromRecord arity (S1 s (K1 i (Semigroup.Option a))) where

1342− recordParseJSON' p obj = wrap <$> recordParseJSON' p obj

1152+ parseRecord opts fargs obj = wrap <$> parseRecord opts fargs obj

1343 where

1153 where

1344 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1154 wrap :: S1 s (K1 i (Maybe a)) p -> S1 s (K1 i (Semigroup.Option a)) p

1345 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

1155 wrap (M1 (K1 a)) = M1 (K1 (Semigroup.Option a))

1346

1156

1347--------------------------------------------------------------------------------

1157--------------------------------------------------------------------------------

1348

1158

1349−productParseJSON0

1350− :: forall f arity a. (ProductFromJSON arity f, ProductSize f)

1351− => ConName :* TypeName :* Options :* FromArgs arity a

1352− -> Value -> Parser (f a)

1353− -- Products are expected to be encoded to an array. Here we check whether we

1354− -- got an array of the same size as the product, then parse each of the

1355− -- product's elements using productParseJSON:

1356−productParseJSON0 p@(cname :* tname :* _ :* _) =

1357− withArray (showCons cname tname) $ \arr ->

1358− let lenArray = V.length arr

1359− lenProduct = (unTagged2 :: Tagged2 f Int -> Int)

1360− productSize in

1361− if lenArray == lenProduct

1362− then productParseJSON p arr 0 lenProduct

1363− else contextCons cname tname $

1364− fail $ "expected an Array of length " ++ show lenProduct ++

1365− ", but encountered an Array of length " ++ show lenArray

1366−

1367−--

1368−

1369−class ProductFromJSON arity f where

1159+class FromProduct arity f where

1370− productParseJSON :: ConName :* TypeName :* Options :* FromArgs arity a

1160+ parseProduct :: Options -> FromArgs arity a

1371 -> Array -> Int -> Int

1161 -> Array -> Int -> Int

1372 -> Parser (f a)

1162 -> Parser (f a)

1373

1163

1374−instance ( ProductFromJSON arity a

1164+instance ( FromProduct arity a

1375− , ProductFromJSON arity b

1165+ , FromProduct arity b

1376− ) => ProductFromJSON arity (a :*: b) where

1166+ ) => FromProduct arity (a :*: b) where

1377− productParseJSON p arr ix len =

1167+ parseProduct opts fargs arr ix len =

1378− (:*:) <$> productParseJSON p arr ix lenL

1168+ (:*:) <$> parseProduct opts fargs arr ix lenL

1379− <*> productParseJSON p arr ixR lenR

1169+ <*> parseProduct opts fargs arr ixR lenR

1380 where

1170 where

1381 lenL = len `unsafeShiftR` 1

1171 lenL = len `unsafeShiftR` 1

1382 ixR = ix + lenL

1172 ixR = ix + lenL

1383 lenR = len - lenL

1173 lenR = len - lenL

1384

1174

1385−instance (GFromJSON arity a) => ProductFromJSON arity (S1 s a) where

1175+instance (GFromJSON arity a) => FromProduct arity (S1 s a) where

1386− productParseJSON (_ :* _ :* opts :* fargs) arr ix _ =

1176+ parseProduct opts fargs arr ix _ =

1387− M1 <$> gParseJSON opts fargs (V.unsafeIndex arr ix) <?> Index ix

1177+ gParseJSON opts fargs $ V.unsafeIndex arr ix

1388

1178

1389--------------------------------------------------------------------------------

1179--------------------------------------------------------------------------------

1390

1180

1391class FromPair arity f where

1181class FromPair arity f where

1392− -- The first component of the parameter tuple is the tag to match.

1393− parsePair :: Text :* TypeName :* Options :* FromArgs arity a

1182+ parsePair :: Options -> FromArgs arity a

1394− -> Value

1395− -> Maybe (Parser (f a))

1183+ -> Pair -> Maybe (Parser (f a))

1396

1184

1397instance ( FromPair arity a

1185instance ( FromPair arity a

1398 , FromPair arity b

1186 , FromPair arity b

1399 ) => FromPair arity (a :+: b) where

1187 ) => FromPair arity (a :+: b) where

1400− parsePair p pair =

1401− (fmap L1 <$> parsePair p pair) <|>

1188+ parsePair opts fargs pair = (fmap L1 <$> parsePair opts fargs pair) <|>

1402− (fmap R1 <$> parsePair p pair)

1189+ (fmap R1 <$> parsePair opts fargs pair)

1403

1190

1404instance ( Constructor c

1191instance ( Constructor c

1192+ , GFromJSON arity a

1405 , ConsFromJSON arity a

1193 , ConsFromJSON arity a

1406 ) => FromPair arity (C1 c a) where

1194 ) => FromPair arity (C1 c a) where

1407− parsePair (tag :* p@(_ :* opts :* _)) v

1195+ parsePair opts fargs (tag, value)

1408− | tag == tag' = Just $ M1 <$> consParseJSON (cname :* p) v

1196+ | tag == tag' = Just $ gParseJSON opts fargs value

1409 | otherwise = Nothing

1197 | otherwise = Nothing

1410− where

1198+ where

1411− tag' = pack $ constructorTagModifier opts cname

1199+ tag' = pack $ constructorTagModifier opts $

1412− cname = conName (undefined :: M1 _i c _a _p)

1200+ conName (undefined :: t c a p)

1413

1201

1414--------------------------------------------------------------------------------

1202--------------------------------------------------------------------------------

1415

1203

1416class FromUntaggedValue arity f where

1204class FromUntaggedValue arity f where

1417− parseUntaggedValue :: TypeName :* Options :* FromArgs arity a

1205+ parseUntaggedValue :: Options -> FromArgs arity a

1418− -> Value

1419− -> Parser (f a)

1206+ -> Value -> Parser (f a)

1420

1207

1421instance

1208instance

1422 ( FromUntaggedValue arity a

1209 ( FromUntaggedValue arity a

1423 , FromUntaggedValue arity b

1210 , FromUntaggedValue arity b

1424 ) => FromUntaggedValue arity (a :+: b)

1211 ) => FromUntaggedValue arity (a :+: b)

1425 where

1212 where

1426− parseUntaggedValue p value =

1213+ parseUntaggedValue opts fargs value =

1427− L1 <$> parseUntaggedValue p value <|>

1214+ L1 <$> parseUntaggedValue opts fargs value <|>

1428− R1 <$> parseUntaggedValue p value

1215+ R1 <$> parseUntaggedValue opts fargs value

1429

1216

1430instance OVERLAPPABLE_

1217instance OVERLAPPABLE_

1431− ( ConsFromJSON arity a

1218+ ( GFromJSON arity a

1432− , Constructor c

1219+ , ConsFromJSON arity a

1433 ) => FromUntaggedValue arity (C1 c a)

1220 ) => FromUntaggedValue arity (C1 c a)

1434 where

1221 where

1435− parseUntaggedValue p = fmap M1 . consParseJSON (cname :* p)

1222+ parseUntaggedValue = gParseJSON

1436− where

1437− cname = conName (undefined :: M1 _i c _f _p)

1438

1223

1439instance OVERLAPPING_

1224instance OVERLAPPING_

1440 ( Constructor c )

1225 ( Constructor c )

1441 => FromUntaggedValue arity (C1 c U1)

1226 => FromUntaggedValue arity (C1 c U1)

1442 where

1227 where

1443− parseUntaggedValue (tname :* opts :* _) v =

1228+ parseUntaggedValue opts _ (String s)

1444− contextCons cname tname $ case v of

1229+ | s == pack (constructorTagModifier opts (conName (undefined :: t c U1 p))) =

1445− String tag

1446− | tag == tag' -> pure $ M1 U1

1230+ pure $ M1 U1

1447− | otherwise -> fail_ tag

1231+ | otherwise =

1448− _ -> typeMismatch "String" v

1232+ fail $ "Invalid tag: " ++ unpack s

1449− where

1233+ parseUntaggedValue _ _ v = typeMismatch (conName (undefined :: t c U1 p)) v

1450− tag' = pack $ constructorTagModifier opts cname

1234+

1451− cname = conName (undefined :: M1 _i c _f _p)

1235+

1452− fail_ tag = fail $

1236+--------------------------------------------------------------------------------

1453− "expected tag " ++ show tag' ++ ", but found tag " ++ show tag

1237+

1238+notFound :: Text -> Parser a

1239+notFound key = fail $ "The key \"" ++ unpack key ++ "\" was not found"

1240+{-# INLINE notFound #-}

1454

1241

1455-------------------------------------------------------------------------------

1242-------------------------------------------------------------------------------

1456-- Instances

1243-- Instances

@@ -1576,22 +1363,12 @@ instance FromJSONKey Float where

1576 _ -> Scientific.toRealFloat <$> parseScientificText t

1363 _ -> Scientific.toRealFloat <$> parseScientificText t

1577

1364

1578instance (FromJSON a, Integral a) => FromJSON (Ratio a) where

1365instance (FromJSON a, Integral a) => FromJSON (Ratio a) where

1579− parseJSON (Number x)

1580− | exp10 <= 1024

1581− , exp10 >= -1024 = return $! realToFrac x

1582− | otherwise = prependContext "Ratio" $ fail msg

1583− where

1584− exp10 = base10Exponent x

1585− msg = "found a number with exponent " ++ show exp10

1586− ++ ", but it must not be greater than 1024 or less than -1024"

1587− parseJSON o = objParser o

1588− where

1589− objParser = withObject "Rational" $ \obj -> do

1366+ parseJSON = withObject "Rational" $ \obj -> do

1590− numerator <- obj .: "numerator"

1367+ numerator <- obj .: "numerator"

1591− denominator <- obj .: "denominator"

1368+ denominator <- obj .: "denominator"

1592− if denominator == 0

1369+ if denominator == 0

1593− then fail "Ratio denominator was 0"

1370+ then fail "Ratio denominator was 0"

1594− else pure $ numerator % denominator

1371+ else pure $ numerator % denominator

1595 {-# INLINE parseJSON #-}

1372 {-# INLINE parseJSON #-}

1596

1373

1597-- | This instance includes a bounds check to prevent maliciously

1374-- | This instance includes a bounds check to prevent maliciously

@@ -1742,7 +1519,7 @@ instance FromJSON1 NonEmpty where

1742 liftParseJSON p _ = withArray "NonEmpty" $

1519 liftParseJSON p _ = withArray "NonEmpty" $

1743 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

1520 (>>= ne) . Tr.sequence . zipWith (parseIndexedJSON p) [0..] . V.toList

1744 where

1521 where

1745− ne [] = fail "parsing NonEmpty failed, unexpected empty list"

1522+ ne [] = fail "parsing NonEmpty failed, unpexpected empty list"

1746 ne (x:xs) = pure (x :| xs)

1523 ne (x:xs) = pure (x :| xs)

1747 {-# INLINE liftParseJSON #-}

1524 {-# INLINE liftParseJSON #-}

1748

1525

@@ -1997,7 +1774,7 @@ instance FromJSON DotNetTime where

1997 parseJSON = withText "DotNetTime" $ \t ->

1774 parseJSON = withText "DotNetTime" $ \t ->

1998 let (s,m) = T.splitAt (T.length t - 5) t

1775 let (s,m) = T.splitAt (T.length t - 5) t

1999 t' = T.concat [s,".",m]

1776 t' = T.concat [s,".",m]

2000− in case parseTimeM True defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

1777+ in case parseTime defaultTimeLocale "/Date(%s%Q)/" (unpack t') of

2001 Just d -> pure (DotNetTime d)

1778 Just d -> pure (DotNetTime d)

2002 _ -> fail "could not parse .NET time"

1779 _ -> fail "could not parse .NET time"

2003 {-# INLINE parseJSON #-}

1780 {-# INLINE parseJSON #-}

@@ -2006,6 +1783,7 @@ instance FromJSON DotNetTime where

2006-- primitive

1783-- primitive

2007-------------------------------------------------------------------------------

1784-------------------------------------------------------------------------------

2008

1785

1786+#if MIN_VERSION_base(4,7,0)

2009instance FromJSON a => FromJSON (PM.Array a) where

1787instance FromJSON a => FromJSON (PM.Array a) where

2010 -- note: we could do better than this if vector exposed the data

1788 -- note: we could do better than this if vector exposed the data

2011 -- constructor in Data.Vector.

1789 -- constructor in Data.Vector.

@@ -2018,7 +1796,6 @@ instance FromJSON a => FromJSON (PM.SmallArray a) where

2018instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where

1796instance (PM.Prim a,FromJSON a) => FromJSON (PM.PrimArray a) where

2019 parseJSON = fmap Exts.fromList . parseJSON

1797 parseJSON = fmap Exts.fromList . parseJSON

2020

1798

2021−#if !MIN_VERSION_primitive(0,7,0)

2022instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where

1799instance (PM.PrimUnlifted a,FromJSON a) => FromJSON (PM.UnliftedArray a) where

2023 parseJSON = fmap Exts.fromList . parseJSON

1800 parseJSON = fmap Exts.fromList . parseJSON

2024#endif

1801#endif

@@ -2091,40 +1868,6 @@ instance FromJSON DiffTime where

2091 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac

1868 parseJSON = withBoundedScientific "DiffTime" $ pure . realToFrac

2092 {-# INLINE parseJSON #-}

1869 {-# INLINE parseJSON #-}

2093

1870

2094−instance FromJSON SystemTime where

2095− parseJSON v = prependContext "SystemTime" $ do

2096− n <- parseJSON v

2097− let n' = floor (n * fromInteger (resolution n) :: Nano)

2098− let (secs, nano) = n' `divMod` resolution n

2099− return (MkSystemTime (fromInteger secs) (fromInteger nano))

2100−

2101−instance FromJSON CalendarDiffTime where

2102− parseJSON = withObject "CalendarDiffTime" $ \obj -> CalendarDiffTime

2103− <$> obj .: "months"

2104− <*> obj .: "time"

2105−

2106−instance FromJSON CalendarDiffDays where

2107− parseJSON = withObject "CalendarDiffDays" $ \obj -> CalendarDiffDays

2108− <$> obj .: "months"

2109− <*> obj .: "days"

2110−

2111−instance FromJSON DayOfWeek where

2112− parseJSON = withText "DaysOfWeek" parseDayOfWeek

2113−

2114−parseDayOfWeek :: T.Text -> Parser DayOfWeek

2115−parseDayOfWeek t = case T.toLower t of

2116− "monday" -> return Monday

2117− "tuesday" -> return Tuesday

2118− "wednesday" -> return Wednesday

2119− "thursday" -> return Thursday

2120− "friday" -> return Friday

2121− "saturday" -> return Saturday

2122− "sunday" -> return Sunday

2123− _ -> fail "Invalid week day"

2124−

2125−instance FromJSONKey DayOfWeek where

2126− fromJSONKey = FromJSONKeyTextParser parseDayOfWeek

2127−

2128-------------------------------------------------------------------------------

1871-------------------------------------------------------------------------------

2129-- base Monoid/Semigroup

1872-- base Monoid/Semigroup

2130-------------------------------------------------------------------------------

1873-------------------------------------------------------------------------------

Data/Aeson/Types/Generic.hs+1−10

@@ -1,10 +1,10 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DataKinds #-}

3−{-# LANGUAGE DeriveFunctor #-}

4{-# LANGUAGE EmptyDataDecls #-}

3{-# LANGUAGE EmptyDataDecls #-}

5{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FunctionalDependencies #-}

5{-# LANGUAGE FunctionalDependencies #-}

7{-# LANGUAGE KindSignatures #-}

6{-# LANGUAGE KindSignatures #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE NoImplicitPrelude #-}

9{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE TypeOperators #-}

@@ -35,7 +35,6 @@ module Data.Aeson.Types.Generic

35 , Zero

36 , One

37 , ProductSize(..)

38− , (:*)(..)

39 ) where

38 ) where

41import Prelude.Compat

40import Prelude.Compat

@@ -76,7 +75,6 @@ instance AllNullary (Rec1 f) False

76instance AllNullary U1 True

75instance AllNullary U1 True

78newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

77newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}

79− deriving Functor

81--------------------------------------------------------------------------------

79--------------------------------------------------------------------------------

@@ -109,10 +107,3 @@ instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where

109

107

110instance ProductSize (S1 s a) where

108instance ProductSize (S1 s a) where

111 productSize = Tagged2 1

109 productSize = Tagged2 1

112−

113−--------------------------------------------------------------------------------

114−

115−-- | Simple extensible tuple type to simplify passing around many parameters.

116−data a :* b = a :* b

117−

118−infixr 1 :*

Data/Aeson/Types/Internal.hs+5−105

@@ -49,8 +49,6 @@ module Data.Aeson.Types.Internal

49 , parserThrowError

50 , parserCatchError

51 , formatError

52− , formatPath

53− , formatRelativePath

54 , (<?>)

52 , (<?>)

55 -- * Constructors and accessors

53 -- * Constructors and accessors

56 , object

54 , object

@@ -64,14 +62,11 @@ module Data.Aeson.Types.Internal

64 , sumEncoding

62 , sumEncoding

65 , unwrapUnaryRecords

63 , unwrapUnaryRecords

66 , tagSingleConstructors

64 , tagSingleConstructors

67− , rejectUnknownFields

68 )

65 )

70 , SumEncoding(..)

67 , SumEncoding(..)

71− , JSONKeyOptions(keyModifier)

72 , defaultOptions

68 , defaultOptions

73 , defaultTaggedObject

69 , defaultTaggedObject

74− , defaultJSONKeyOptions

76 -- * Used for changing CamelCase names into something else.

71 -- * Used for changing CamelCase names into something else.

77 , camelTo

72 , camelTo

@@ -102,7 +97,6 @@ import Data.Time.Format (FormatTime)

102import Data.Typeable (Typeable)

97import Data.Typeable (Typeable)

103import Data.Vector (Vector)

98import Data.Vector (Vector)

104import GHC.Generics (Generic)

99import GHC.Generics (Generic)

105−import qualified Control.Monad as Monad

106import qualified Control.Monad.Fail as Fail

100import qualified Control.Monad.Fail as Fail

107import qualified Data.HashMap.Strict as H

101import qualified Data.HashMap.Strict as H

108import qualified Data.Scientific as S

102import qualified Data.Scientific as S

@@ -156,7 +150,7 @@ instance Functor Result where

156 fmap _ (Error err) = Error err

150 fmap _ (Error err) = Error err

157 {-# INLINE fmap #-}

151 {-# INLINE fmap #-}

158

152

159−instance Monad.Monad IResult where

153+instance Monad IResult where

160 return = pure

154 return = pure

161 {-# INLINE return #-}

155 {-# INLINE return #-}

162

156

@@ -164,16 +158,14 @@ instance Monad.Monad IResult where

164 IError path err >>= _ = IError path err

158 IError path err >>= _ = IError path err

165 {-# INLINE (>>=) #-}

159 {-# INLINE (>>=) #-}

166

160

167−#if !(MIN_VERSION_base(4,13,0))

168 fail = Fail.fail

161 fail = Fail.fail

169 {-# INLINE fail #-}

162 {-# INLINE fail #-}

170−#endif

171

163

172instance Fail.MonadFail IResult where

164instance Fail.MonadFail IResult where

173 fail err = IError [] err

165 fail err = IError [] err

174 {-# INLINE fail #-}

166 {-# INLINE fail #-}

175

167

176−instance Monad.Monad Result where

168+instance Monad Result where

177 return = pure

169 return = pure

178 {-# INLINE return #-}

170 {-# INLINE return #-}

179

171

@@ -181,10 +173,8 @@ instance Monad.Monad Result where

181 Error err >>= _ = Error err

173 Error err >>= _ = Error err

182 {-# INLINE (>>=) #-}

174 {-# INLINE (>>=) #-}

183

175

184−#if !(MIN_VERSION_base(4,13,0))

185 fail = Fail.fail

176 fail = Fail.fail

186 {-# INLINE fail #-}

177 {-# INLINE fail #-}

187−#endif

188

178

189instance Fail.MonadFail Result where

179instance Fail.MonadFail Result where

190 fail err = Error err

180 fail err = Error err

@@ -292,17 +282,14 @@ newtype Parser a = Parser {

292 -> f r

282 -> f r

293 }

283 }

294

284

295−instance Monad.Monad Parser where

285+instance Monad Parser where

296 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks

286 m >>= g = Parser $ \path kf ks -> let ks' a = runParser (g a) path kf ks

297 in runParser m path kf ks'

287 in runParser m path kf ks'

298 {-# INLINE (>>=) #-}

288 {-# INLINE (>>=) #-}

299 return = pure

289 return = pure

300 {-# INLINE return #-}

290 {-# INLINE return #-}

301−

302−#if !(MIN_VERSION_base(4,13,0))

303 fail = Fail.fail

291 fail = Fail.fail

304 {-# INLINE fail #-}

292 {-# INLINE fail #-}

305−#endif

306

293

307instance Fail.MonadFail Parser where

294instance Fail.MonadFail Parser where

308 fail msg = Parser $ \path kf _ks -> kf (reverse path) msg

295 fail msg = Parser $ \path kf _ks -> kf (reverse path) msg

@@ -461,17 +448,7 @@ parseEither m v = runParser (m v) [] onError Right

461-- | Annotate an error message with a

448-- | Annotate an error message with a

462-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.

449-- <http://goessner.net/articles/JsonPath/ JSONPath> error location.

463formatError :: JSONPath -> String -> String

450formatError :: JSONPath -> String -> String

464−formatError path msg = "Error in " ++ formatPath path ++ ": " ++ msg

451+formatError path msg = "Error in " ++ format "$" path ++ ": " ++ msg

465−

466−-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String',

467−-- representing the root object as @$@.

468−formatPath :: JSONPath -> String

469−formatPath path = "$" ++ formatRelativePath path

470−

471−-- | Format a <http://goessner.net/articles/JsonPath/ JSONPath> as a 'String'

472−-- which represents the path relative to some root object.

473−formatRelativePath :: JSONPath -> String

474−formatRelativePath path = format "" path

475 where

452 where

476 format :: String -> JSONPath -> String

453 format :: String -> JSONPath -> String

477 format pfx [] = pfx

454 format pfx [] = pfx

@@ -584,39 +561,6 @@ data Options = Options

584 -- ^ If 'True' record fields with a 'Nothing' value will be

561 -- ^ If 'True' record fields with a 'Nothing' value will be

585 -- omitted from the resulting object. If 'False' the resulting

562 -- omitted from the resulting object. If 'False' the resulting

586 -- object will include those fields mapping to @null@.

563 -- object will include those fields mapping to @null@.

587− --

588− -- === Note

589− --

590− -- Setting 'omitNothingFields' to 'True' only affects fields which are of

591− -- type 'Maybe' /uniformly/ in the 'ToJSON' or 'FromJSON' instance. In

592− -- particular, if the type of a field is declared as a type variable, it

593− -- will not be omitted from the JSON object, unless the field is

594− -- specialized upfront in the instance.

595− --

596− -- ==== __Example__

597− --

598− -- The generic instance for the following type @Fruit@ depends on whether

599− -- the instance head is @Fruit a@ or @Fruit (Maybe a)@.

600− --

601− -- @

602− -- data Fruit a =

603− -- { apples :: a -- A field whose type is a type variable.

604− -- , oranges :: 'Maybe' Int

605− -- }

606− --

607− -- options :: 'Options'

608− -- options = 'defaultOptions' { 'omitNothingFields' = 'True' }

609− --

610− -- -- apples required, oranges optional

611− -- -- Even if 'Data.Aeson.fromJSON' is then specialized to (Fruit ('Maybe' a)).

612− -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit a) where

613− -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options

614− --

615− -- -- apples optional, oranges optional

616− -- -- In this instance, the field apples is uniformly of type ('Maybe' a).

617− -- instance 'Data.Aeson.FromJSON' a => 'Data.Aeson.FromJSON' (Fruit ('Maybe' a)) where

618− -- 'Data.Aeson.fromJSON' = 'Data.Aeson.genericFromJSON' options

619− -- @

620 , sumEncoding :: SumEncoding

564 , sumEncoding :: SumEncoding

621 -- ^ Specifies how to encode constructors of a sum datatype.

565 -- ^ Specifies how to encode constructors of a sum datatype.

622 , unwrapUnaryRecords :: Bool

566 , unwrapUnaryRecords :: Bool

@@ -625,14 +569,10 @@ data Options = Options

625 , tagSingleConstructors :: Bool

569 , tagSingleConstructors :: Bool

626 -- ^ Encode types with a single constructor as sums,

570 -- ^ Encode types with a single constructor as sums,

627 -- so that `allNullaryToStringTag` and `sumEncoding` apply.

571 -- so that `allNullaryToStringTag` and `sumEncoding` apply.

628− , rejectUnknownFields :: Bool

629− -- ^ Applies only to 'Data.Aeson.FromJSON' instances. If a field appears in

630− -- the parsed object map, but does not appear in the target object, parsing

631− -- will fail, with an error message indicating which fields were unknown.

632 }

572 }

633

573

634instance Show Options where

574instance Show Options where

635− show (Options f c a o s u t r) =

575+ show (Options f c a o s u t) =

636 "Options {"

576 "Options {"

637 ++ intercalate ", "

577 ++ intercalate ", "

638 [ "fieldLabelModifier =~ " ++ show (f "exampleField")

578 [ "fieldLabelModifier =~ " ++ show (f "exampleField")

@@ -642,7 +582,6 @@ instance Show Options where

642 , "sumEncoding = " ++ show s

582 , "sumEncoding = " ++ show s

643 , "unwrapUnaryRecords = " ++ show u

583 , "unwrapUnaryRecords = " ++ show u

644 , "tagSingleConstructors = " ++ show t

584 , "tagSingleConstructors = " ++ show t

645− , "rejectUnknownFields = " ++ show r

646 ]

585 ]

647 ++ "}"

586 ++ "}"

648

587

@@ -686,33 +625,6 @@ data SumEncoding =

686 -- contents of the constructor.

625 -- contents of the constructor.

687 deriving (Eq, Show)

626 deriving (Eq, Show)

688

627

689−-- | Options for encoding keys with 'Data.Aeson.Types.genericFromJSONKey' and

690−-- 'Data.Aeson.Types.genericToJSONKey'.

691−data JSONKeyOptions = JSONKeyOptions

692− { keyModifier :: String -> String

693− -- ^ Function applied to keys. Its result is what goes into the encoded

694− -- 'Value'.

695− --

696− -- === __Example__

697− --

698− -- The following instances encode the constructor @Bar@ to lower-case keys

699− -- @\"bar\"@.

700− --

701− -- @

702− -- data Foo = Bar

703− -- deriving 'Generic'

704− --

705− -- opts :: 'JSONKeyOptions'

706− -- opts = 'defaultJSONKeyOptions' { 'keyModifier' = 'toLower' }

707− --

708− -- instance 'ToJSONKey' Foo where

709− -- 'toJSONKey' = 'genericToJSONKey' opts

710− --

711− -- instance 'FromJSONKey' Foo where

712− -- 'fromJSONKey' = 'genericFromJSONKey' opts

713− -- @

714− }

715−

716-- | Default encoding 'Options':

628-- | Default encoding 'Options':

717--

629--

718-- @

630-- @

@@ -724,7 +636,6 @@ data JSONKeyOptions = JSONKeyOptions

724-- , 'sumEncoding' = 'defaultTaggedObject'

636-- , 'sumEncoding' = 'defaultTaggedObject'

725-- , 'unwrapUnaryRecords' = False

637-- , 'unwrapUnaryRecords' = False

726-- , 'tagSingleConstructors' = False

638-- , 'tagSingleConstructors' = False

727−-- , 'rejectUnknownFields' = False

728-- }

639-- }

729-- @

640-- @

730defaultOptions :: Options

641defaultOptions :: Options

@@ -736,7 +647,6 @@ defaultOptions = Options

736 , sumEncoding = defaultTaggedObject

647 , sumEncoding = defaultTaggedObject

737 , unwrapUnaryRecords = False

648 , unwrapUnaryRecords = False

738 , tagSingleConstructors = False

649 , tagSingleConstructors = False

739− , rejectUnknownFields = False

740 }

650 }

741

651

742-- | Default 'TaggedObject' 'SumEncoding' options:

652-- | Default 'TaggedObject' 'SumEncoding' options:

@@ -753,16 +663,6 @@ defaultTaggedObject = TaggedObject

753 , contentsFieldName = "contents"

663 , contentsFieldName = "contents"

754 }

664 }

755

665

756−-- | Default 'JSONKeyOptions':

757−--

758−-- @

759−-- defaultJSONKeyOptions = 'JSONKeyOptions'

760−-- { 'keyModifier' = 'id'

761−-- }

762−-- @

763−defaultJSONKeyOptions :: JSONKeyOptions

764−defaultJSONKeyOptions = JSONKeyOptions id

765−

766-- | Converts from CamelCase to another lower case, interspersing

666-- | Converts from CamelCase to another lower case, interspersing

767-- the character between all capital letters and their previous

667-- the character between all capital letters and their previous

768-- entries, except those capital letters that appear together,

668-- entries, except those capital letters that appear together,

Data/Aeson/Types/ToJSON.hs+52−98

@@ -5,15 +5,21 @@

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE FunctionalDependencies #-}

7{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE NamedFieldPuns #-}

8{-# LANGUAGE NoImplicitPrelude #-}

10{-# LANGUAGE NoImplicitPrelude #-}

9{-# LANGUAGE OverloadedStrings #-}

11{-# LANGUAGE OverloadedStrings #-}

10{-# LANGUAGE PatternGuards #-}

12{-# LANGUAGE PatternGuards #-}

11−{-# LANGUAGE PolyKinds #-}

12{-# LANGUAGE RecordWildCards #-}

13{-# LANGUAGE RecordWildCards #-}

13{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE TypeOperators #-}

15{-# LANGUAGE TypeOperators #-}

16+{-# LANGUAGE TypeSynonymInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

17{-# LANGUAGE UndecidableInstances #-}

19+#if __GLASGOW_HASKELL__ >= 706

20+{-# LANGUAGE PolyKinds #-}

21+#endif

22+

17#include "overlapping-compat.h"

23#include "overlapping-compat.h"

18#include "incoherent-compat.h"

24#include "incoherent-compat.h"

@@ -43,10 +49,6 @@ module Data.Aeson.Types.ToJSON

43 , ToJSONKeyFunction(..)

49 , ToJSONKeyFunction(..)

44 , toJSONKeyText

50 , toJSONKeyText

45 , contramapToJSONKeyFunction

51 , contramapToJSONKeyFunction

46−

47− , GToJSONKey()

48− , genericToJSONKey

49−

50 -- * Object key-value pairs

52 -- * Object key-value pairs

51 , KeyValue(..)

53 , KeyValue(..)

52 , KeyValuePair(..)

54 , KeyValuePair(..)

@@ -69,7 +71,7 @@ import Data.Aeson.Types.Internal

69import Data.Attoparsec.Number (Number(..))

71import Data.Attoparsec.Number (Number(..))

70import Data.Bits (unsafeShiftR)

72import Data.Bits (unsafeShiftR)

71import Data.DList (DList)

73import Data.DList (DList)

72−import Data.Fixed (Fixed, HasResolution, Nano)

74+import Data.Fixed (Fixed, HasResolution)

73import Data.Foldable (toList)

75import Data.Foldable (toList)

74import Data.Functor.Compose (Compose(..))

76import Data.Functor.Compose (Compose(..))

75import Data.Functor.Contravariant (Contravariant (..))

77import Data.Functor.Contravariant (Contravariant (..))

@@ -86,10 +88,8 @@ import Data.Scientific (Scientific)

86import Data.Tagged (Tagged(..))

88import Data.Tagged (Tagged(..))

87import Data.Text (Text, pack)

89import Data.Text (Text, pack)

88import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

90import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

89−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))

90−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))

91−import Data.Time.Clock.System.Compat (SystemTime (..))

92−import Data.Time.Format.Compat (FormatTime, formatTime, defaultTimeLocale)

91+import Data.Time.Format (FormatTime, formatTime)

92+import Data.Time.Locale.Compat (defaultTimeLocale)

93import Data.Vector (Vector)

94import Data.Version (Version, showVersion)

95import Data.Void (Void, absurd)

@@ -100,6 +100,7 @@ import GHC.Generics

100import Numeric.Natural (Natural)

101import qualified Data.Aeson.Encoding as E

102import qualified Data.Aeson.Encoding.Internal as E (InArray, comma, econcat, retagEncoding)

103+import qualified Data.ByteString as S

103import qualified Data.ByteString.Lazy as L

104import qualified Data.ByteString.Lazy as L

104import qualified Data.DList as DList

105import qualified Data.DList as DList

105import qualified Data.HashMap.Strict as H

106import qualified Data.HashMap.Strict as H

@@ -134,12 +135,20 @@ import qualified Data.Primitive.SmallArray as PM

134import qualified Data.Primitive.Types as PM

135import qualified Data.Primitive.Types as PM

135

136

136#if MIN_VERSION_primitive(0,6,4)

137#if MIN_VERSION_primitive(0,6,4)

137−#if !MIN_VERSION_primitive(0,7,0)

138import qualified Data.Primitive.UnliftedArray as PM

139−#endif

140import qualified Data.Primitive.PrimArray as PM

139import qualified Data.Primitive.PrimArray as PM

141#endif

140#endif

142

141

142+#if !(MIN_VERSION_bytestring(0,10,0))

143+import Foreign.ForeignPtr (withForeignPtr)

144+import Foreign.Marshal.Utils (copyBytes)

145+import Foreign.Ptr (plusPtr)

146+import qualified Data.ByteString.Internal as S

147+import qualified Data.ByteString.Lazy.Internal as L

148+#endif

149+

150+{-# ANN module ("HLint: ignore Reduce duplication"::String) #-}

151+

143toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

152toJSONPair :: (a -> Value) -> (b -> Value) -> (a, b) -> Value

144toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)

153toJSONPair a b = liftToJSON2 a (listValue a) b (listValue b)

145{-# INLINE toJSONPair #-}

154{-# INLINE toJSONPair #-}

@@ -402,7 +411,7 @@ instance KeyValue Object where

402-- newtype wrapper around 'Text'. The recommended approach is to use

411-- newtype wrapper around 'Text'. The recommended approach is to use

403-- generalized newtype deriving:

412-- generalized newtype deriving:

404--

413--

405−-- > newtype RecordId = RecordId { getRecordId :: Text }

414+-- > newtype RecordId = RecordId { getRecordId :: Text}

406-- > deriving (Eq,Ord,ToJSONKey)

415-- > deriving (Eq,Ord,ToJSONKey)

407--

416--

408-- Then we may write:

417-- Then we may write:

@@ -417,18 +426,8 @@ instance KeyValue Object where

417--

426--

418-- It is possible to get the 'ToJSONKey' instance for free as we did

427-- It is possible to get the 'ToJSONKey' instance for free as we did

419-- with 'Foo'. However, in this case, we have a natural way to go to

428-- with 'Foo'. However, in this case, we have a natural way to go to

420−-- and from 'Text' that does not require any escape sequences. So

429+-- and from 'Text' that does not require any escape sequences. So, in

421−-- 'ToJSONKeyText' can be used instead of 'ToJSONKeyValue' to encode maps

430+-- this example, 'ToJSONKeyText' will be used instead of 'ToJSONKeyValue'.

422−-- as objects instead of arrays of pairs. This instance may be

423−-- implemented using generics as follows:

424−--

425−-- @

426−-- instance 'ToJSONKey' Color where

427−-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'

428−-- @

429−--

430−-- === __Low-level implementations__

431−--

432-- The 'Show' instance can be used to help write 'ToJSONKey':

431-- The 'Show' instance can be used to help write 'ToJSONKey':

433--

432--

434-- > instance ToJSONKey Color where

433-- > instance ToJSONKey Color where

@@ -503,7 +502,7 @@ toJSONKeyTextEnc e = ToJSONKeyText tot e

503 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm

502 -- TODO: dropAround is also used in stringEncoding, which is unfortunate atm

504 tot = T.dropAround (== '"')

503 tot = T.dropAround (== '"')

505 . T.decodeLatin1

504 . T.decodeLatin1

506− . L.toStrict

505+ . lazyToStrictByteString

507 . E.encodingToLazyByteString

506 . E.encodingToLazyByteString

508 . e

507 . e

509

508

@@ -516,29 +515,6 @@ contramapToJSONKeyFunction h x = case x of

516 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)

515 ToJSONKeyText f g -> ToJSONKeyText (f . h) (g . h)

517 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)

516 ToJSONKeyValue f g -> ToJSONKeyValue (f . h) (g . h)

518

517

519−-- 'toJSONKey' for 'Generic' types.

520−-- Deriving is supported for enumeration types, i.e. the sums of nullary

521−-- constructors. The names of constructors will be used as keys for JSON

522−-- objects.

523−--

524−-- See also 'genericFromJSONKey'.

525−--

526−-- === __Example__

527−--

528−-- @

529−-- data Color = Red | Green | Blue

530−-- deriving 'Generic'

531−--

532−-- instance 'ToJSONKey' Color where

533−-- 'toJSONKey' = 'genericToJSONKey' 'defaultJSONKeyOptions'

534−-- @

535−genericToJSONKey :: (Generic a, GToJSONKey (Rep a))

536− => JSONKeyOptions -> ToJSONKeyFunction a

537−genericToJSONKey opts = toJSONKeyText (pack . keyModifier opts . getConName . from)

538−

539−class GetConName f => GToJSONKey f

540−instance GetConName f => GToJSONKey f

541−

542-------------------------------------------------------------------------------

518-------------------------------------------------------------------------------

543-- Lifings of FromJSON and ToJSON to unary and binary type constructors

519-- Lifings of FromJSON and ToJSON to unary and binary type constructors

544-------------------------------------------------------------------------------

520-------------------------------------------------------------------------------

@@ -968,9 +944,6 @@ instance (GetConName a, GetConName b) => GetConName (a :+: b) where

968instance (Constructor c) => GetConName (C1 c a) where

944instance (Constructor c) => GetConName (C1 c a) where

969 getConName = conName

945 getConName = conName

970

946

971−-- For genericToJSONKey

972−instance GetConName a => GetConName (D1 d a) where

973− getConName (M1 x) = getConName x

974

947

975--------------------------------------------------------------------------------

948--------------------------------------------------------------------------------

976

949

@@ -1970,6 +1943,7 @@ formatMillis = take 3 . formatTime defaultTimeLocale "%q"

1970-- primitive

1943-- primitive

1971-------------------------------------------------------------------------------

1944-------------------------------------------------------------------------------

1972

1945

1946+#if MIN_VERSION_base(4,7,0)

1973instance ToJSON a => ToJSON (PM.Array a) where

1947instance ToJSON a => ToJSON (PM.Array a) where

1974 -- note: we could do better than this if vector exposed the data

1948 -- note: we could do better than this if vector exposed the data

1975 -- constructor in Data.Vector.

1949 -- constructor in Data.Vector.

@@ -1985,7 +1959,6 @@ instance (PM.Prim a,ToJSON a) => ToJSON (PM.PrimArray a) where

1985 toJSON = toJSON . Exts.toList

1959 toJSON = toJSON . Exts.toList

1986 toEncoding = toEncoding . Exts.toList

1960 toEncoding = toEncoding . Exts.toList

1987

1961

1988−#if !MIN_VERSION_primitive(0,7,0)

1989instance (PM.PrimUnlifted a,ToJSON a) => ToJSON (PM.UnliftedArray a) where

1962instance (PM.PrimUnlifted a,ToJSON a) => ToJSON (PM.UnliftedArray a) where

1990 toJSON = toJSON . Exts.toList

1963 toJSON = toJSON . Exts.toList

1991 toEncoding = toEncoding . Exts.toList

1964 toEncoding = toEncoding . Exts.toList

@@ -2040,7 +2013,7 @@ stringEncoding :: Encoding' Text -> Value

2040stringEncoding = String

2013stringEncoding = String

2041 . T.dropAround (== '"')

2014 . T.dropAround (== '"')

2042 . T.decodeLatin1

2015 . T.decodeLatin1

2043− . L.toStrict

2016+ . lazyToStrictByteString

2044 . E.encodingToLazyByteString

2017 . E.encodingToLazyByteString

2045{-# INLINE stringEncoding #-}

2018{-# INLINE stringEncoding #-}

2046

2019

@@ -2060,50 +2033,6 @@ instance ToJSON DiffTime where

2060 toEncoding = E.scientific . realToFrac

2033 toEncoding = E.scientific . realToFrac

2061 {-# INLINE toEncoding #-}

2034 {-# INLINE toEncoding #-}

2062

2035

2063−-- | Encoded as number

2064−instance ToJSON SystemTime where

2065− toJSON (MkSystemTime secs nsecs) =

2066− toJSON (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)

2067− toEncoding (MkSystemTime secs nsecs) =

2068− toEncoding (fromIntegral secs + fromIntegral nsecs / 1000000000 :: Nano)

2069−

2070−instance ToJSON CalendarDiffTime where

2071− toJSON (CalendarDiffTime m nt) = object

2072− [ "months" .= m

2073− , "time" .= nt

2074− ]

2075− toEncoding (CalendarDiffTime m nt) = E.pairs

2076− ("months" .= m <> "time" .= nt)

2077−

2078−instance ToJSON CalendarDiffDays where

2079− toJSON (CalendarDiffDays m d) = object

2080− [ "months" .= m

2081− , "days" .= d

2082− ]

2083− toEncoding (CalendarDiffDays m d) = E.pairs

2084− ("months" .= m <> "days" .= d)

2085−

2086−instance ToJSON DayOfWeek where

2087− toJSON Monday = "monday"

2088− toJSON Tuesday = "tuesday"

2089− toJSON Wednesday = "wednesday"

2090− toJSON Thursday = "thursday"

2091− toJSON Friday = "friday"

2092− toJSON Saturday = "saturday"

2093− toJSON Sunday = "sunday"

2094−

2095−toEncodingDayOfWeek :: DayOfWeek -> E.Encoding' Text

2096−toEncodingDayOfWeek Monday = E.unsafeToEncoding "\"monday\""

2097−toEncodingDayOfWeek Tuesday = E.unsafeToEncoding "\"tuesday\""

2098−toEncodingDayOfWeek Wednesday = E.unsafeToEncoding "\"wednesday\""

2099−toEncodingDayOfWeek Thursday = E.unsafeToEncoding "\"thursday\""

2100−toEncodingDayOfWeek Friday = E.unsafeToEncoding "\"friday\""

2101−toEncodingDayOfWeek Saturday = E.unsafeToEncoding "\"saturday\""

2102−toEncodingDayOfWeek Sunday = E.unsafeToEncoding "\"sunday\""

2103−

2104−instance ToJSONKey DayOfWeek where

2105− toJSONKey = toJSONKeyTextEnc toEncodingDayOfWeek

2106−

2107-------------------------------------------------------------------------------

2036-------------------------------------------------------------------------------

2108-- base Monoid/Semigroup

2037-- base Monoid/Semigroup

2109-------------------------------------------------------------------------------

2038-------------------------------------------------------------------------------

@@ -2847,6 +2776,31 @@ instance (ToJSON a, ToJSON b, ToJSON c, ToJSON d, ToJSON e, ToJSON f, ToJSON g,

2847 toEncoding = toEncoding2

2776 toEncoding = toEncoding2

2848 {-# INLINE toEncoding #-}

2777 {-# INLINE toEncoding #-}

2849

2778

2779+-------------------------------------------------------------------------------

2780+-- pre-bytestring-0.10 compatibility

2781+-------------------------------------------------------------------------------

2782+

2783+{-# INLINE lazyToStrictByteString #-}

2784+lazyToStrictByteString :: L.ByteString -> S.ByteString

2785+#if MIN_VERSION_bytestring(0,10,0)

2786+lazyToStrictByteString = L.toStrict

2787+#else

2788+lazyToStrictByteString = packChunks

2789+

2790+-- packChunks is taken from the blaze-builder package.

2791+

2792+-- | Pack the chunks of a lazy bytestring into a single strict bytestring.

2793+packChunks :: L.ByteString -> S.ByteString

2794+packChunks lbs =

2795+ S.unsafeCreate (fromIntegral $ L.length lbs) (copyChunks lbs)

2796+ where

2797+ copyChunks L.Empty _pf = return ()

2798+ copyChunks (L.Chunk (S.PS fpbuf o l) lbs') pf = do

2799+ withForeignPtr fpbuf $ \pbuf ->

2800+ copyBytes pf (pbuf `plusPtr` o) l

2801+ copyChunks lbs' (pf `plusPtr` l)

2802+#endif

2803+

2850--------------------------------------------------------------------------------

2804--------------------------------------------------------------------------------

2851

2805

2852-- | Wrap a list of pairs as an object.

2806-- | Wrap a list of pairs as an object.

HLint.hsnew file+12

@@ -0,0 +1,12 @@

1+module HLint.HLint where

3+import "hint" HLint.Default

4+import "hint" HLint.Builtin.All

5+import "hint" HLint.Dollar

7+ignore "Avoid lambda"

8+ignore "Eta reduce"

9+ignore "Functor law"

10+ignore "Use >=>"

11+ignore "Use lambda-case"

12+ignore "Use $>"

Makefile+1−1

@@ -1,2 +1,2 @@

1lint:

2− ./run-hlint.sh --cpp-include include/ --cpp-file travis/cabal_macros.h Data/ attoparsec-iso8601/ benchmarks/ examples/ ffi/ pure/ tests/

2+ hlint --cpp-include include/ --cpp-file .stack-work/dist/*/*Cabal-*/build/autogen/cabal_macros.h Data/ attoparsec-iso8601/ benchmarks/ examples/ ffi/ pure/ tests/

aeson.cabal+24−21

@@ -1,5 +1,5 @@

1name: aeson

2−version: 1.4.6.0

2+version: 1.4.2.0

3license: BSD3

4license-file: LICENSE

5category: Text, Web, JSON

@@ -88,6 +88,7 @@ library

88 Data.Aeson.Encode

90 other-modules:

91+ Data.Aeson.Compat

91 Data.Aeson.Encoding.Builder

92 Data.Aeson.Encoding.Builder

92 Data.Aeson.Internal.Functions

93 Data.Aeson.Internal.Functions

93 Data.Aeson.Parser.Unescape

94 Data.Aeson.Parser.Unescape

@@ -102,22 +103,23 @@ library

102

103

103 -- GHC bundled libs

104 -- GHC bundled libs

104 build-depends:

105 build-depends:

105− base >= 4.7.0.0 && < 5,

106+ base >= 4.5.0.0 && < 5,

106− bytestring >= 0.10.4.0 && < 0.11,

107− containers >= 0.5.5.1 && < 0.7,

107+ containers >= 0.4.2.1 && < 0.7,

108 deepseq >= 1.3.0.0 && < 1.5,

109 ghc-prim >= 0.2 && < 0.6,

110− template-haskell >= 2.9.0.0 && < 2.16,

110+ template-haskell >= 2.7.0.0 && < 2.15,

111 text >= 1.2.3.0 && < 1.3,

112− time >= 1.4 && < 1.10

112+ time >= 1.4 && < 1.9

113−

114− if impl(ghc >= 8.0)

115− build-depends: bytestring >= 0.10.8.1

116

113

117 -- Compat

114 -- Compat

118 build-depends:

115 build-depends:

119− base-compat >= 0.9.1 && < 0.12,

116+ base-compat >= 0.9.1 && < 0.11

120− time-compat >= 1.9.2.2 && < 1.10

117+

118+ if flag(bytestring-builder)

119+ build-depends: bytestring >= 0.9.2 && < 0.10.4,

120+ bytestring-builder >= 0.10.4 && < 1

121+ else

122+ build-depends: bytestring >= 0.10.4 && < 0.11

121

123

122 if !impl(ghc >= 8.6)

124 if !impl(ghc >= 8.6)

123 build-depends:

125 build-depends:

@@ -126,7 +128,7 @@ library

126 if !impl(ghc >= 8.0)

128 if !impl(ghc >= 8.0)

127 -- `Data.Semigroup` and `Control.Monad.Fail` and `Control.Monad.IO.Class` are available in base only since GHC 8.0 / base 4.9

129 -- `Data.Semigroup` and `Control.Monad.Fail` and `Control.Monad.IO.Class` are available in base only since GHC 8.0 / base 4.9

128 build-depends:

130 build-depends:

129− semigroups >= 0.18.5 && < 0.20,

131+ semigroups >= 0.18.5 && < 0.19,

130 transformers >= 0.3.0.0 && < 0.6,

132 transformers >= 0.3.0.0 && < 0.6,

131 transformers-compat >= 0.6.2 && < 0.7,

133 transformers-compat >= 0.6.2 && < 0.7,

132 fail == 4.9.*

134 fail == 4.9.*

@@ -142,15 +144,16 @@ library

142

144

143 -- not in LTS-12.10

145 -- not in LTS-12.10

144 tagged >= 0.8.5 && < 0.9,

146 tagged >= 0.8.5 && < 0.9,

145− primitive >= 0.6.3.0 && < 0.8

147+ primitive >= 0.6.3.0 && < 0.7

146

148

147 -- Other dependencies

149 -- Other dependencies

148 build-depends:

150 build-depends:

149 attoparsec >= 0.13.2.2 && < 0.14,

151 attoparsec >= 0.13.2.2 && < 0.14,

150 dlist >= 0.8.0.4 && < 0.9,

152 dlist >= 0.8.0.4 && < 0.9,

151− hashable >= 1.2.7.0 && < 1.4,

153+ hashable >= 1.2.7.0 && < 1.3,

152 scientific >= 0.3.6.2 && < 0.4,

154 scientific >= 0.3.6.2 && < 0.4,

153− th-abstraction >= 0.2.8.0 && < 0.4,

155+ th-abstraction >= 0.2.8.0 && < 0.3,

156+ time-locale-compat >= 0.1.1.5 && < 0.2,

154 uuid-types >= 1.0.3 && < 1.1,

157 uuid-types >= 1.0.3 && < 1.1,

155 vector >= 0.12.0.1 && < 0.13

158 vector >= 0.12.0.1 && < 0.13

156

159

@@ -208,7 +211,7 @@ test-suite tests

208 UnitTests.NullaryConstructors

211 UnitTests.NullaryConstructors

209

212

210 build-depends:

213 build-depends:

211− QuickCheck >= 2.10.0.1 && < 2.14,

214+ QuickCheck >= 2.10.0.1 && < 2.13,

212 aeson,

215 aeson,

213 integer-logarithms >= 1 && <1.1,

216 integer-logarithms >= 1 && <1.1,

214 attoparsec,

217 attoparsec,

@@ -219,9 +222,9 @@ test-suite tests

219 containers,

222 containers,

220 directory,

223 directory,

221 dlist,

224 dlist,

222− Diff >= 0.4 && < 0.5,

225+ Diff,

223 filepath,

226 filepath,

224− generic-deriving >= 1.10 && < 1.14,

227+ generic-deriving >= 1.10 && < 1.13,

225 ghc-prim >= 0.2,

228 ghc-prim >= 0.2,

226 hashable >= 1.2.4.0,

229 hashable >= 1.2.4.0,

227 scientific,

230 scientific,

@@ -233,11 +236,11 @@ test-suite tests

233 tasty-quickcheck,

236 tasty-quickcheck,

234 text,

237 text,

235 time,

238 time,

236− time-compat,

239+ time-locale-compat,

237 unordered-containers,

240 unordered-containers,

238 uuid-types,

241 uuid-types,

239 vector,

242 vector,

240− quickcheck-instances >= 0.3.21 && <0.4

243+ quickcheck-instances >= 0.3.16

241

244

242 if flag(bytestring-builder)

245 if flag(bytestring-builder)

243 build-depends: bytestring >= 0.9 && < 0.10.4,

246 build-depends: bytestring >= 0.9 && < 0.10.4,

@@ -247,7 +250,7 @@ test-suite tests

247

250

248 if !impl(ghc >= 8.0)

251 if !impl(ghc >= 8.0)

249 build-depends:

252 build-depends:

250− semigroups >= 0.18.2 && < 0.20,

253+ semigroups >= 0.18.2 && < 0.19,

251 transformers >= 0.2.2.0,

254 transformers >= 0.2.2.0,

252 transformers-compat >= 0.3

255 transformers-compat >= 0.3

253

256

attoparsec-iso8601/Data/Attoparsec/Time/Internal.hs+20

@@ -29,8 +29,16 @@ import Data.Time.Clock (diffTimeToPicoseconds)

30#endif

32+#if MIN_VERSION_base(4,7,0)

33+

32import Data.Fixed (Pico, Fixed(MkFixed))

34import Data.Fixed (Pico, Fixed(MkFixed))

36+#else

37+

38+import Data.Fixed (Pico)

39+

40+#endif

41+

34#if !MIN_VERSION_time(1,6,0)

42#if !MIN_VERSION_time(1,6,0)

36diffTimeToPicoseconds :: DiffTime -> Integer

44diffTimeToPicoseconds :: DiffTime -> Integer

@@ -38,12 +46,24 @@ diffTimeToPicoseconds = unsafeCoerce

39#endif

47#endif

49+#if MIN_VERSION_base(4,7,0)

50+

41toPico :: Integer -> Pico

51toPico :: Integer -> Pico

42toPico = MkFixed

52toPico = MkFixed

44fromPico :: Pico -> Integer

54fromPico :: Pico -> Integer

45fromPico (MkFixed i) = i

55fromPico (MkFixed i) = i

57+#else

58+

59+toPico :: Integer -> Pico

60+toPico = unsafeCoerce

61+

62+fromPico :: Pico -> Integer

63+fromPico = unsafeCoerce

64+

65+#endif

66+

47-- | Like TimeOfDay, but using a fixed-width integer for seconds.

67-- | Like TimeOfDay, but using a fixed-width integer for seconds.

48data TimeOfDay64 = TOD {-# UNPACK #-} !Int

68data TimeOfDay64 = TOD {-# UNPACK #-} !Int

49 {-# UNPACK #-} !Int

69 {-# UNPACK #-} !Int

attoparsec-iso8601/attoparsec-iso8601.cabal+2−2

@@ -36,8 +36,8 @@ library

36 Data.Attoparsec.Time

37 build-depends:

38 attoparsec >= 0.13.0.1,

39− base >= 4.7 && < 5,

39+ base >= 4.5 && < 5,

40− base-compat >= 0.9.1 && < 0.12,

40+ base-compat >= 0.9.1 && < 0.11,

41 text >= 1.1.1.0,

42 time >= 1.1.1.4

benchmarks/AesonEncode.hs+1−1

@@ -7,7 +7,7 @@ module Main (main) where

7import Prelude.Compat

9import Control.DeepSeq

10−import Control.Monad (forM_)

10+import Control.Monad

11import Data.Aeson

12import Data.Attoparsec.ByteString (IResult(..), parseWith)

13import Data.Char (isDigit)

benchmarks/Compare/JsonBench.hs+3−4

@@ -20,7 +20,6 @@ import Data.Aeson ((.:))

20import Data.Monoid ((<>))

21import Data.Text (Text)

22import Typed.Common (load)

23−import qualified Control.Monad.Fail as Fail

24import qualified Data.Aeson as Aeson

23import qualified Data.Aeson as Aeson

25import qualified Data.BufferBuilder.Json as Json

24import qualified Data.BufferBuilder.Json as Json

@@ -69,10 +68,10 @@ instance NFData Gender where rnf !_ = ()

69instance NFData Fruit where rnf !_ = ()

68instance NFData Fruit where rnf !_ = ()

71instance NFData Friend where

70instance NFData Friend where

72− rnf Friend {..} = rnf fId `seq` rnf fName

71+ rnf Friend {..} = rnf fId `seq` rnf fName `seq` ()

74instance NFData User where

73instance NFData User where

75− rnf User {..} = rnf uId `seq` rnf uIndex `seq` rnf uGuid `seq` rnf uIsActive `seq` rnf uBalance `seq` rnf uPicture `seq` rnf uAge `seq` rnf uEyeColor `seq` rnf uName `seq` rnf uGender `seq` rnf uCompany `seq` rnf uEmail `seq` rnf uPhone `seq` rnf uAddress `seq` rnf uAbout `seq` rnf uRegistered `seq` rnf uLatitude `seq` rnf uLongitude `seq` rnf uTags `seq` rnf uFriends `seq` rnf uGreeting `seq` rnf uFavouriteFruit

74+ rnf User {..} = rnf uId `seq` rnf uIndex `seq` rnf uGuid `seq` rnf uIsActive `seq` rnf uBalance `seq` rnf uPicture `seq` rnf uAge `seq` rnf uEyeColor `seq` rnf uName `seq` rnf uGender `seq` rnf uCompany `seq` rnf uEmail `seq` rnf uPhone `seq` rnf uAddress `seq` rnf uAbout `seq` rnf uRegistered `seq` rnf uLatitude `seq` rnf uLongitude `seq` rnf uTags `seq` rnf uFriends `seq` rnf uGreeting `seq` rnf uFavouriteFruit `seq` ()

77eyeColorTable :: [(Text, EyeColor)]

76eyeColorTable :: [(Text, EyeColor)]

78eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)]

77eyeColorTable = [("brown", Brown), ("green", Green), ("blue", Blue)]

@@ -83,7 +82,7 @@ genderTable = [("male", Male), ("female", Female)]

83fruitTable :: [(Text, Fruit)]

82fruitTable :: [(Text, Fruit)]

84fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]

83fruitTable = [("apple", Apple), ("strawberry", Strawberry), ("banana", Banana)]

86−enumFromJson :: Fail.MonadFail m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum

85+enumFromJson :: Monad m => String -> [(Text, enum)] -> (json -> m Text) -> json -> m enum

87enumFromJson enumName table extract v = do

86enumFromJson enumName table extract v = do

88 s <- extract v

87 s <- extract v

89 case lookup s table of

88 case lookup s table of

benchmarks/CompareWithJSON.hs+1−1

@@ -27,7 +27,7 @@ instance (NFData v) => NFData (J.JSObject v) where

27instance NFData J.JSValue where

28 rnf J.JSNull = ()

29 rnf (J.JSBool b) = rnf b

30− rnf (J.JSRational a b) = rnf a `seq` rnf b

30+ rnf (J.JSRational a b) = rnf a `seq` rnf b `seq` ()

31 rnf (J.JSString s) = rnf (J.fromJSString s)

32 rnf (J.JSArray lst) = rnf lst

33 rnf (J.JSObject o) = rnf o

benchmarks/Issue673.hs−1

@@ -18,7 +18,6 @@ import Criterion.Main

18import Prelude.Compat

19import Data.Int (Int64)

20import Data.Scientific (Scientific)

21−import Data.Semigroup ((<>))

22import Data.Aeson.Parser (scientific)

21import Data.Aeson.Parser (scientific)

24import qualified Data.Attoparsec.ByteString.Lazy as AttoL

23import qualified Data.Attoparsec.ByteString.Lazy as AttoL

benchmarks/JsonParse.hs+1−1

@@ -17,7 +17,7 @@ import Text.JSON

17instance NFData JSValue where

18 rnf JSNull = ()

19 rnf (JSBool b) = rnf b

20− rnf (JSRational b r) = rnf b `seq` rnf r

20+ rnf (JSRational b r) = rnf b `seq` rnf r `seq` ()

21 rnf (JSString s) = rnf (fromJSString s)

22 rnf (JSArray vs) = rnf vs

23 rnf (JSObject kvs) = rnf (fromJSObject kvs)

benchmarks/aeson-benchmarks.cabal+28−32

@@ -28,42 +28,44 @@ library

28 hs-source-dirs: .. ../ffi ../pure ../attoparsec-iso8601

29 c-sources: ../cbits/unescape_string.c

30 build-depends:

31− attoparsec,

31+ attoparsec >= 0.13.0.1,

32− base,

32+ base == 4.*,

33− base-compat,

33+ base-compat >= 0.9.1 && <0.11,

34+ time-locale-compat >=0.1.1 && <0.2,

34 containers,

35 containers,

35 deepseq,

36 deepseq,

36− dlist,

37+ dlist >= 0.2,

37− fail,

38+ fail == 4.9.*,

38− ghc-prim,

39+ ghc-prim >= 0.2,

39− hashable,

40+ hashable >= 1.1.2.0,

40 mtl,

41 mtl,

41− primitive,

42+ primitive >= 0.6.1,

42− scientific,

43+ scientific >= 0.3.4.7 && < 0.4,

43 syb,

44 syb,

44− tagged,

45+ tagged >=0.8.3 && <0.9,

45− template-haskell,

46+ template-haskell >= 2.4,

46− text,

47+ text >= 1.2.3,

47− th-abstraction,

48+ th-abstraction >= 0.2.2 && < 0.3,

48− time-compat,

49 time,

50 transformers,

51− unordered-containers,

51+ unordered-containers >= 0.2.3.0,

52− uuid-types,

52+ uuid-types >= 1.0.3 && <1.1,

53− vector

53+ vector >= 0.7.1

55− if !impl(ghc >= 8.6)

55+ if !impl(ghc >= 7.10)

56+ -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8

56− build-depends: contravariant

57+ build-depends: nats >= 1 && < 1.2

58+

59+ if impl(ghc >=7.8)

60+ cpp-options: -DHAS_COERCIBLE

58 if !impl(ghc >= 8.0)

62 if !impl(ghc >= 8.0)

59 -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9

63 -- `Data.Semigroup` is available in base only since GHC 8.0 / base 4.9

60− build-depends: semigroups,

64+ build-depends: semigroups >= 0.18.2 && < 0.19

61− transformers-compat

63− if !impl(ghc >= 7.10)

66+ if !impl(ghc >= 8.6)

64− -- `Numeric.Natural` is available in base only since GHC 7.10 / base 4.8

65− build-depends: nats,

67+ build-depends:

66− void

68+ contravariant >=1.4.1 && <1.6

68 include-dirs: ../include

70 include-dirs: ../include

@@ -72,6 +74,7 @@ library

73 exposed-modules:

75 exposed-modules:

74 Data.Aeson

76 Data.Aeson

77+ Data.Aeson.Compat

75 Data.Aeson.Encoding

78 Data.Aeson.Encoding

76 Data.Aeson.Encoding.Builder

79 Data.Aeson.Encoding.Builder

77 Data.Aeson.Encoding.Internal

80 Data.Aeson.Encoding.Internal

@@ -175,9 +178,6 @@ executable aeson-benchmark-compare

175 Compare.JsonBuilder

178 Compare.JsonBuilder

176 build-depends:

179 build-depends:

177 json-builder

180 json-builder

178− if impl(ghc < 8.0)

179− build-depends:

180− semigroups

181

182executable aeson-benchmark-micro

183 default-language: Haskell2010

@@ -224,8 +224,6 @@ executable aeson-benchmark-typed

224 bytestring-builder >= 0.10.4 && < 1

225 else

226 build-depends: bytestring >= 0.10.4

227− if impl(ghc < 8.0)

228− build-depends: semigroups

229

227

230executable aeson-benchmark-compare-with-json

228executable aeson-benchmark-compare-with-json

231 default-language: Haskell2010

229 default-language: Haskell2010

@@ -341,5 +339,3 @@ executable aeson-issue-673

341 scientific,

339 scientific,

342 base-compat,

340 base-compat,

343 criterion >= 1.0

341 criterion >= 1.0

344− if impl(ghc < 8.0)

345− build-depends: semigroups

cabal.project+1−4

@@ -1,5 +1,2 @@

1with-compiler: ghc

2−packages: .

3−packages: attoparsec-iso8601

2+packages: ., attoparsec-iso8601, benchmarks

4−-- packages: benchmarks

5−tests: true

changelog.md−70

@@ -1,75 +1,5 @@

1For the latest version of this document, please see [https://github.com/bos/aeson/blob/master/changelog.md](https://github.com/bos/aeson/blob/master/changelog.md).

3−### upcoming

4−

5−* `FromJSON` instance of `Ratio a` now parses numbers in addtion to

6− standard `{numerator=..., denumerator=...}` encoding.

7−

8−### 1.4.6.0

9−

10−* Provide a clearer error message when a required tagKey for a constructor is missing, thanks to Guru Devanla.

11− The error message now looks like this: `Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found`

12−

13−* Add `formatPath` and `formatRelativePath` functions to turn a `JSONPath` into a `String`, thanks to Robbie McMichael

14−

15−

16−### 1.4.5.0

17−

18−* Expose `(<?>)`, `JSONPath` and `JSONPathElement(..)` from `Data.Aeson.Types`. Previously only available through internal modules. Thanks to Luke Clifton.

19−

20−* Support for base-compat 0.11, thanks to Ryan Scott.

21−

22−* Travis build for GHC 8.8, thanks to Oleg Grenrus.

23−

24−### 1.4.4.0

25−

26−**New features**:

27−

28−* Adds a parameterized parser `jsonWith` that can be used to choose how to handle duplicate keys in objects, thanks to Xia Li-Yao.

29−

30−* Add generic implementations of `FromJSONKey` and `ToJSONKey`, thanks to Xia Li-Yao. Example:

31−

32−```haskell

33−data Foo = Bar

34− deriving Generic

35−

36−opts :: JSONKeyOptions

37−opts = defaultJSONKeyOptions { keyModifier = toLower }

38−

39−instance ToJSONKey Foo where

40− toJSONKey = genericToJSONKey opts

41−

42−instance FromJSONKey Foo where

43− fromJSONKey = genericFromJSONKey opts

44−```

45−

46−**Minor**:

47−* aeson now uses `time-compat` instead of `time-locale-compat`, thanks to Oleg Grenrus.

48−* Prepare for `MonadFail` breakages in GHC 8.8, thanks to Oleg Grenrus.

49−* Require `bytestring >= 0.10.8.1` for newer GHCs to avoid build failures, thanks to Oleg Grenrus.

50−* Support `primitive 0.7.*`, thanks to Adam Bergmark.

51−* Allow `semigroups 0.19.*` and `hashable 1.3.*`, thanks to Oleg Grenrus.

52−* Fix a typo in the error message when parsing `NonEmpty`, thanks to Colin Woodbury.

53−* Document surprising behavior when using `omitNothingFields` with type variables, thanks to Xia Li-Yao.

54−

55−**Internal changes**:

56−* Code cleanup by Oleg Grenrus

57−* Fix dependencies of the benchmarks on older GHC's, thanks to Xia Li-Yao.

58−

59−### 1.4.3.0

60−* Improve error messages for FromJSON in existing instances and GHC Generic implementation. Thanks to Xia Li-Yao & Igor Pashev.

61−* Tweak error-reporting combinators and their documentation. Thanks to Xia Li-Yao.

62− * `typeMismatch` is now about comparing JSON types (i.e., the expected and actual names of the Value constructor).

63− * `withObject` and other `with*` combinators now also mention the JSON types they expect

64− * New `unexpected` and `prependFailure` combinators.

65−* Add `Contravariant` `ToJSONKeyFunction` instance. Thanks to Oleg Grenrus.

66−* Add `KeyValue` instance for `Object`. Thanks to Robert Hensing.

67−* Improve performance when parsing certain large numbers, thanks to Oleg Grenrus.

68−* Add `Data.Aeson.QQ.Simple` - A limited version of aeson-qq. Thanks to Oleg Grenrus.

69−* Exposes internal helper functions like `<?>`, `JSONPath`, and `parseIndexedJSON` from `Data.Aeson` module. Thanks to Abid Uzair.

70−* Better error messages when there are syntax errors parsing objects and arrays. Thanks to Fintan Halpenny.

71−* Support building with `th-abstraction-0.3.0.0` or later. Thanks to Ryan Scott.

72−

73### 1.4.2.0

3### 1.4.2.0

75* Add `Data.Aeson.QQ.Simple` which is a simpler version of the `aeson-qq` package, it does not support interpolation, thanks to Oleg Grenrus.

5* Add `Data.Aeson.QQ.Simple` which is a simpler version of the `aeson-qq` package, it does not support interpolation, thanks to Oleg Grenrus.

run-hlint.shdeleted−7

@@ -1,7 +0,0 @@

1−#!/bin/bash

2−

3−if hash hlint 2>/dev/null; then

4− hlint "$@"

5−else

6− ./hlint.sh "$@"

7−fi

stack-bench.yaml+1−2

@@ -1,4 +1,4 @@

1−resolver: nightly-2019-09-21

1+resolver: lts-12.10

2# We use aeson in the snapshot to

3# - avoid recompilation of criterion

4# - compare against it

@@ -9,4 +9,3 @@ resolver: nightly-2019-09-21

9work-dir: .stack-work-bench

10packages:

11- benchmarks

12−extra-deps: []

stack-ffi-unescape.yaml+2−2

@@ -1,4 +1,4 @@

1−resolver: nightly-2019-09-21

1+resolver: lts-12.10

2packages:

3- '.'

4flags:

@@ -6,4 +6,4 @@ flags:

6 fast: true

7 cffi: true

8extra-deps:

9−- Diff-0.4.0

9+- hashable-time-0.2.0.1

stack-lts12.yaml+1−6

@@ -1,4 +1,4 @@

1−resolver: lts-12.26

1+resolver: lts-12.10

2packages:

3- '.'

4- attoparsec-iso8601

@@ -7,9 +7,4 @@ flags:

7 fast: true

8 cffi: true

9extra-deps:

10−- base-orphans-0.8.1

11- hashable-time-0.2.0.1

10- hashable-time-0.2.0.1

12−- QuickCheck-2.13.1

13−- quickcheck-instances-0.3.21

14−- splitmix-0.0.2

15−- time-compat-1.9.2.2

stack-nightly.yaml+1−3

@@ -1,4 +1,4 @@

1−resolver: nightly-2019-10-14

1+resolver: nightly-2018-09-26

2packages:

3- '.'

4- attoparsec-iso8601

@@ -7,5 +7,3 @@ flags:

7 fast: true

8 attoparsec-iso8601:

9 fast: true

10−extra-deps:

11−- generic-deriving-1.12.4

tests/Encoders.hs+6−48

@@ -6,7 +6,6 @@

6module Encoders (module Encoders) where

8import Prelude.Compat

9−import Data.Text (Text)

11import Data.Aeson.TH

10import Data.Aeson.TH

12import Data.Aeson.Types

11import Data.Aeson.Types

@@ -97,18 +96,6 @@ gNullaryToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingle

97gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary

96gNullaryParseJSONObjectWithSingleField :: Value -> Parser Nullary

98gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

97gNullaryParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

100−keyOptions :: JSONKeyOptions

101−keyOptions = defaultJSONKeyOptions { keyModifier = ('k' :) }

102−

103−gNullaryToJSONKey :: Nullary -> Either String Text

104−gNullaryToJSONKey x = case genericToJSONKey keyOptions of

105− ToJSONKeyText p _ -> Right (p x)

106− _ -> Left "Should be a ToJSONKeyText"

107−

108−gNullaryFromJSONKey :: Text -> Parser Nullary

109−gNullaryFromJSONKey t = case genericFromJSONKey keyOptions of

110− FromJSONKeyTextParser p -> p t

111− _ -> fail "Not a TextParser"

112

113--------------------------------------------------------------------------------

100--------------------------------------------------------------------------------

114-- SomeType encoders/decoders

101-- SomeType encoders/decoders

@@ -188,6 +175,7 @@ gSomeTypeToEncoding2ElemArray = genericToEncoding opts2ElemArray

188gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)

175gSomeTypeParseJSON2ElemArray :: Value -> Parser (SomeType Int)

189gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray

176gSomeTypeParseJSON2ElemArray = genericParseJSON opts2ElemArray

190

177

178+#if __GLASGOW_HASKELL__ >= 706

191gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a

179gSomeTypeLiftToEncoding2ElemArray :: LiftToEncoding SomeType a

192gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray

180gSomeTypeLiftToEncoding2ElemArray = genericLiftToEncoding opts2ElemArray

193

181

@@ -196,6 +184,7 @@ gSomeTypeLiftToJSON2ElemArray = genericLiftToJSON opts2ElemArray

196

184

197gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a

185gSomeTypeLiftParseJSON2ElemArray :: LiftParseJSON SomeType a

198gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray

186gSomeTypeLiftParseJSON2ElemArray = genericLiftParseJSON opts2ElemArray

187+#endif

199

188

200

189

201gSomeTypeToJSONTaggedObject :: SomeType Int -> Value

190gSomeTypeToJSONTaggedObject :: SomeType Int -> Value

@@ -207,6 +196,7 @@ gSomeTypeToEncodingTaggedObject = genericToEncoding optsTaggedObject

207gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)

196gSomeTypeParseJSONTaggedObject :: Value -> Parser (SomeType Int)

208gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject

197gSomeTypeParseJSONTaggedObject = genericParseJSON optsTaggedObject

209

198

199+#if __GLASGOW_HASKELL__ >= 706

210gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a

200gSomeTypeLiftToEncodingTaggedObject :: LiftToEncoding SomeType a

211gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject

201gSomeTypeLiftToEncodingTaggedObject = genericLiftToEncoding optsTaggedObject

212

202

@@ -215,6 +205,7 @@ gSomeTypeLiftToJSONTaggedObject = genericLiftToJSON optsTaggedObject

215

205

216gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a

206gSomeTypeLiftParseJSONTaggedObject :: LiftParseJSON SomeType a

217gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject

207gSomeTypeLiftParseJSONTaggedObject = genericLiftParseJSON optsTaggedObject

208+#endif

218

209

219

210

220gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value

211gSomeTypeToJSONObjectWithSingleField :: SomeType Int -> Value

@@ -226,6 +217,7 @@ gSomeTypeToEncodingObjectWithSingleField = genericToEncoding optsObjectWithSingl

226gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)

217gSomeTypeParseJSONObjectWithSingleField :: Value -> Parser (SomeType Int)

227gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

218gSomeTypeParseJSONObjectWithSingleField = genericParseJSON optsObjectWithSingleField

228

219

220+#if __GLASGOW_HASKELL__ >= 706

229gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a

221gSomeTypeLiftToEncodingObjectWithSingleField :: LiftToEncoding SomeType a

230gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField

222gSomeTypeLiftToEncodingObjectWithSingleField = genericLiftToEncoding optsObjectWithSingleField

231

223

@@ -234,6 +226,7 @@ gSomeTypeLiftToJSONObjectWithSingleField = genericLiftToJSON optsObjectWithSingl

234

226

235gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a

227gSomeTypeLiftParseJSONObjectWithSingleField :: LiftParseJSON SomeType a

236gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField

228gSomeTypeLiftParseJSONObjectWithSingleField = genericLiftParseJSON optsObjectWithSingleField

229+#endif

237

230

238

231

239gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value

232gSomeTypeToJSONOmitNothingFields :: SomeType Int -> Value

@@ -243,31 +236,6 @@ gSomeTypeToEncodingOmitNothingFields :: SomeType Int -> Encoding

243gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

236gSomeTypeToEncodingOmitNothingFields = genericToEncoding optsOmitNothingFields

244

237

245

238

246−thSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)

247−thSomeTypeParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''SomeType)

248−

249−gSomeTypeParseJSONRejectUnknownFields :: Value -> Parser (SomeType Int)

250−gSomeTypeParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields

251−

252−

253−--------------------------------------------------------------------------------

254−-- Foo decoders

255−--------------------------------------------------------------------------------

256−

257−thFooParseJSONRejectUnknownFields :: Value -> Parser Foo

258−thFooParseJSONRejectUnknownFields = $(mkParseJSON optsRejectUnknownFields ''Foo)

259−

260−gFooParseJSONRejectUnknownFields :: Value -> Parser Foo

261−gFooParseJSONRejectUnknownFields = genericParseJSON optsRejectUnknownFields

262−

263−

264−thFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo

265−thFooParseJSONRejectUnknownFieldsTagged = $(mkParseJSON optsRejectUnknownFieldsTagged ''Foo)

266−

267−gFooParseJSONRejectUnknownFieldsTagged :: Value -> Parser Foo

268−gFooParseJSONRejectUnknownFieldsTagged = genericParseJSON optsRejectUnknownFieldsTagged

269−

270−

271--------------------------------------------------------------------------------

239--------------------------------------------------------------------------------

272-- Option fields

240-- Option fields

273--------------------------------------------------------------------------------

241--------------------------------------------------------------------------------

@@ -446,13 +414,3 @@ gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors

446

414

447gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor

415gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor

448gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors

416gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors

449−

450−--------------------------------------------------------------------------------

451−-- Product2 encoders/decoders

452−--------------------------------------------------------------------------------

453−

454−thProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)

455−thProduct2ParseJSON = $(mkParseJSON defaultOptions ''Product2)

456−

457−gProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)

458−gProduct2ParseJSON = genericParseJSON defaultOptions

tests/ErrorMessages.hs+1−118

@@ -13,7 +13,7 @@ import Data.Aeson (FromJSON(..), Value, json)

13import Data.Aeson.Types (Parser)

14import Data.Aeson.Parser (eitherDecodeWith)

15import Data.Aeson.Internal (formatError, iparse)

16−import Data.Algorithm.Diff (PolyDiff (..), getGroupedDiff)

16+import Data.Algorithm.Diff (Diff(..), getGroupedDiff)

17import Data.Proxy (Proxy(..))

18import Data.Semigroup ((<>))

19import Data.Sequence (Seq)

@@ -24,13 +24,9 @@ import Test.Tasty.Golden.Advanced (goldenTest)

24import qualified Data.ByteString.Lazy.Char8 as L

25import qualified Data.HashMap.Strict as HM

27−import Encoders

28−import Types

29−

30tests :: [TestTree]

27tests :: [TestTree]

31tests =

28tests =

32 [ aesonGoldenTest "simple" "tests/golden/simple.expected" output

29 [ aesonGoldenTest "simple" "tests/golden/simple.expected" output

33− , aesonGoldenTest "generic" "tests/golden/generic.expected" (outputGeneric G)

34 ]

30 ]

36output :: Output

32output :: Output

@@ -74,113 +70,6 @@ output = concat

74 ]

70 ]

75 ]

71 ]

77−data Choice = TH | G

78−

79−outputGeneric :: Choice -> Output

80−outputGeneric choice = concat

81− [ testWith "OneConstructor"

82− (select

83− thOneConstructorParseJSONDefault

84− gOneConstructorParseJSONDefault)

85− [ "\"X\""

86− , "[0]"

87− ]

88−

89− , testWith "Nullary"

90− (select

91− thNullaryParseJSONString

92− gNullaryParseJSONString)

93− [ "\"X\""

94− , "[]"

95− ]

96−

97− , testWithSomeType "SomeType (tagged)"

98− (select

99− thSomeTypeParseJSONTaggedObject

100− gSomeTypeParseJSONTaggedObject)

101− [ "{\"tag\": \"unary\", \"contents\": true}"

102− , "{\"tag\": \"unary\"}"

103− , "{\"tag\": \"record\"}"

104− , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"

105− , "{\"tag\": \"X\"}"

106− , "{}"

107− , "[]"

108− ]

109−

110− , testWithSomeType "SomeType (single-field)"

111− (select

112− thSomeTypeParseJSONObjectWithSingleField

113− gSomeTypeParseJSONObjectWithSingleField)

114− [ "{\"unary\": {}}"

115− , "{\"unary\": []}"

116− , "{\"X\": []}"

117− , "{\"record\": {}, \"W\":{}}"

118− , "{}"

119− , "[]"

120− , "{\"unary\""

121− , "{\"unary\":"

122− , "{\"unary\":1"

123− ]

124−

125− , testWithSomeType "SomeType (two-element array)"

126− (select

127− thSomeTypeParseJSON2ElemArray

128− gSomeTypeParseJSON2ElemArray)

129− [ "[\"unary\", true]"

130− , "[\"record\", null]"

131− , "[\"X\", 0]"

132− , "[null, 0]"

133− , "[]"

134− , "{}"

135− , "[1"

136− , "[1,"

137− ]

138−

139− , testWithSomeType "SomeType (reject unknown fields)"

140− (select

141− thSomeTypeParseJSONRejectUnknownFields

142− gSomeTypeParseJSONRejectUnknownFields)

143− [ "{\"tag\": \"record\", \"testOne\": 1.0, \"testZero\": 1}"

144− , "{\"testZero\": 1}"

145− , "{\"tag\": \"record\", \"testone\": true, \"testtwo\": null, \"testthree\": null}"

146− ]

147−

148− , testWithFoo "Foo (reject unknown fields)"

149− (select

150− thFooParseJSONRejectUnknownFields

151− gFooParseJSONRejectUnknownFields)

152− [ "{\"tag\": \"foo\"}"

153− ]

154−

155− , testWithFoo "Foo (reject unknown fields, tagged single)"

156− (select

157− thFooParseJSONRejectUnknownFieldsTagged

158− gFooParseJSONRejectUnknownFieldsTagged)

159− [ "{\"tag\": \"foo\", \"unknownField\": 0}"

160− ]

161−

162− , testWith "EitherTextInt"

163− (select

164− thEitherTextIntParseJSONUntaggedValue

165− gEitherTextIntParseJSONUntaggedValue)

166− [ "\"X\""

167− , "[]"

168− ]

169−

170− , testWith "Product2 Int Bool"

171− (select

172− thProduct2ParseJSON

173− gProduct2ParseJSON)

174− [ "[1, null]"

175− , "[]"

176− , "{}"

177− ]

178− ]

179− where

180− select a b = case choice of

181− TH -> a

182− G -> b

183−

184-- Test infrastructure

73-- Test infrastructure

185

186type Output = [String]

75type Output = [String]

@@ -216,9 +105,3 @@ testWith name parser ts =

216testFor :: forall a proxy. (FromJSON a, Show a)

105testFor :: forall a proxy. (FromJSON a, Show a)

217 => String -> proxy a -> [L.ByteString] -> Output

106 => String -> proxy a -> [L.ByteString] -> Output

218testFor name _ = testWith name (parseJSON :: Value -> Parser a)

107testFor name _ = testWith name (parseJSON :: Value -> Parser a)

219−

220−testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output

221−testWithSomeType = testWith

222−

223−testWithFoo :: String -> (Value -> Parser Foo) -> [L.ByteString] -> Output

224−testWithFoo = testWith

tests/Instances.hs+4−1

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE FlexibleInstances #-}

3{-# LANGUAGE NoImplicitPrelude #-}

4{-# LANGUAGE NoImplicitPrelude #-}

@@ -24,12 +25,14 @@ import qualified Data.HashMap.Strict as HM

25import Data.Orphans ()

26import Data.Orphans ()

26import Test.QuickCheck.Instances ()

27import Test.QuickCheck.Instances ()

28+#if MIN_VERSION_base(4,7,0)

27import Data.Hashable.Time ()

29import Data.Hashable.Time ()

30+#endif

29-- "System" types.

32-- "System" types.

31instance Arbitrary DotNetTime where

34instance Arbitrary DotNetTime where

32− arbitrary = DotNetTime `fmap` arbitrary

35+ arbitrary = DotNetTime `liftM` arbitrary

33 shrink = map DotNetTime . shrink . fromDotNetTime

36 shrink = map DotNetTime . shrink . fromDotNetTime

35-- | Compare timezone part only on 'timeZoneMinutes'

38-- | Compare timezone part only on 'timeZoneMinutes'

tests/Options.hs−11

@@ -55,14 +55,3 @@ optsOptionField = optsDefault

55 { fieldLabelModifier = const "field"

56 , omitNothingFields = True

57 }

58−

59−optsRejectUnknownFields :: Options

60−optsRejectUnknownFields = optsDefault

61− { rejectUnknownFields = True

62− }

63−

64−optsRejectUnknownFieldsTagged :: Options

65−optsRejectUnknownFieldsTagged = optsDefault

66− { rejectUnknownFields = True

67− , tagSingleConstructors = True

68− }

tests/PropertyGeneric.hs+8

@@ -44,9 +44,11 @@ genericTests =

44 , testProperty "TaggedObject" (toParseJSON gSomeTypeParseJSONTaggedObject gSomeTypeToJSONTaggedObject)

45 , testProperty "ObjectWithSingleField" (toParseJSON gSomeTypeParseJSONObjectWithSingleField gSomeTypeToJSONObjectWithSingleField)

47+#if __GLASGOW_HASKELL__ >= 706

47 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)

48 , testProperty "2ElemArray unary" (toParseJSON1 gSomeTypeLiftParseJSON2ElemArray gSomeTypeLiftToJSON2ElemArray)

48 , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)

49 , testProperty "TaggedObject unary" (toParseJSON1 gSomeTypeLiftParseJSONTaggedObject gSomeTypeLiftToJSONTaggedObject)

49 , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)

50 , testProperty "ObjectWithSingleField unary" (toParseJSON1 gSomeTypeLiftParseJSONObjectWithSingleField gSomeTypeLiftToJSONObjectWithSingleField)

51+#endif

50 ]

52 ]

51 ]

53 ]

52 , testGroup "OneConstructor" [

54 , testGroup "OneConstructor" [

@@ -83,24 +85,30 @@ genericTests =

84 , testProperty "SomeType2ElemArray" $

86 , testProperty "SomeType2ElemArray" $

85 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

87 gSomeTypeToJSON2ElemArray `sameAs` gSomeTypeToEncoding2ElemArray

88+#if __GLASGOW_HASKELL__ >= 706

86 , testProperty "SomeType2ElemArray unary" $

89 , testProperty "SomeType2ElemArray unary" $

87 gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray

90 gSomeTypeLiftToJSON2ElemArray `sameAs1` gSomeTypeLiftToEncoding2ElemArray

88 , testProperty "SomeType2ElemArray unary agree" $

91 , testProperty "SomeType2ElemArray unary agree" $

89 gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray

92 gSomeTypeToEncoding2ElemArray `sameAs1Agree` gSomeTypeLiftToEncoding2ElemArray

93+#endif

91 , testProperty "SomeTypeTaggedObject" $

95 , testProperty "SomeTypeTaggedObject" $

92 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject

96 gSomeTypeToJSONTaggedObject `sameAs` gSomeTypeToEncodingTaggedObject

97+#if __GLASGOW_HASKELL__ >= 706

93 , testProperty "SomeTypeTaggedObject unary" $

98 , testProperty "SomeTypeTaggedObject unary" $

94 gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject

99 gSomeTypeLiftToJSONTaggedObject `sameAs1` gSomeTypeLiftToEncodingTaggedObject

95 , testProperty "SomeTypeTaggedObject unary agree" $

100 , testProperty "SomeTypeTaggedObject unary agree" $

96 gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject

101 gSomeTypeToEncodingTaggedObject `sameAs1Agree` gSomeTypeLiftToEncodingTaggedObject

102+#endif

103

98 , testProperty "SomeTypeObjectWithSingleField" $

104 , testProperty "SomeTypeObjectWithSingleField" $

99 gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField

105 gSomeTypeToJSONObjectWithSingleField `sameAs` gSomeTypeToEncodingObjectWithSingleField

106+#if __GLASGOW_HASKELL__ >= 706

100 , testProperty "SomeTypeObjectWithSingleField unary" $

107 , testProperty "SomeTypeObjectWithSingleField unary" $

101 gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField

108 gSomeTypeLiftToJSONObjectWithSingleField `sameAs1` gSomeTypeLiftToEncodingObjectWithSingleField

102 , testProperty "SomeTypeObjectWithSingleField unary agree" $

109 , testProperty "SomeTypeObjectWithSingleField unary agree" $

103 gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField

110 gSomeTypeToEncodingObjectWithSingleField `sameAs1Agree` gSomeTypeLiftToEncodingObjectWithSingleField

111+#endif

104

112

105 , testProperty "SomeTypeOmitNothingFields" $

113 , testProperty "SomeTypeOmitNothingFields" $

106 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

114 gSomeTypeToJSONOmitNothingFields `sameAs` gSomeTypeToEncodingOmitNothingFields

tests/PropertyKeys.hs+3

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE NoImplicitPrelude #-}

2{-# LANGUAGE NoImplicitPrelude #-}

3module PropertyKeys ( keysTests ) where

4module PropertyKeys ( keysTests ) where

@@ -30,10 +31,12 @@ keysTests =

30 , testProperty "Natural" $ roundTripKey (undefined :: Natural)

31 , testProperty "Natural" $ roundTripKey (undefined :: Natural)

31 , testProperty "Float" $ roundTripKey (undefined :: Float)

32 , testProperty "Float" $ roundTripKey (undefined :: Float)

32 , testProperty "Double" $ roundTripKey (undefined :: Double)

33 , testProperty "Double" $ roundTripKey (undefined :: Double)

34+#if MIN_VERSION_base(4,7,0)

33 , testProperty "Day" $ roundTripKey (undefined :: Day)

35 , testProperty "Day" $ roundTripKey (undefined :: Day)

34 , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)

36 , testProperty "LocalTime" $ roundTripKey (undefined :: LocalTime)

35 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)

37 , testProperty "TimeOfDay" $ roundTripKey (undefined :: TimeOfDay)

36 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)

38 , testProperty "UTCTime" $ roundTripKey (undefined :: UTCTime)

39+#endif

37 , testProperty "Version" $ roundTripKey (undefined :: Version)

40 , testProperty "Version" $ roundTripKey (undefined :: Version)

38 , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)

41 , testProperty "Lazy Text" $ roundTripKey (undefined :: LT.Text)

39 , testProperty "UUID" $ roundTripKey UUID.nil

42 , testProperty "UUID" $ roundTripKey UUID.nil

tests/PropertyRoundTrip.hs−7

@@ -14,9 +14,6 @@ import Data.Sequence (Seq)

14import Data.Tagged (Tagged)

15import Data.Time (Day, DiffTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime)

16import Data.Version (Version)

17−import Data.Time.Calendar.Compat (CalendarDiffDays, DayOfWeek)

18−import Data.Time.LocalTime.Compat (CalendarDiffTime)

19−import Data.Time.Clock.System.Compat (SystemTime)

20import Instances ()

17import Instances ()

21import Numeric.Natural (Natural)

18import Numeric.Natural (Natural)

22import Test.Tasty (TestTree, testGroup)

19import Test.Tasty (TestTree, testGroup)

@@ -50,10 +47,6 @@ roundTripTests =

50 , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)

47 , testProperty "ZonedTime" $ roundTripEq (undefined :: ZonedTime)

51 , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)

48 , testProperty "NominalDiffTime" $ roundTripEq (undefined :: NominalDiffTime)

52 , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)

49 , testProperty "DiffTime" $ roundTripEq (undefined :: DiffTime)

53− , testProperty "DayOfWeek" $ roundTripEq (undefined :: DayOfWeek)

54− , testProperty "SystemTime" $ roundTripEq (undefined :: SystemTime)

55− , testProperty "CalendarDiffTime" $ roundTripEq (undefined :: CalendarDiffTime)

56− , testProperty "CalendarDiffDays" $ roundTripEq (undefined :: CalendarDiffDays)

57 , testProperty "Version" $ roundTripEq (undefined :: Version)

50 , testProperty "Version" $ roundTripEq (undefined :: Version)

58 , testProperty "Natural" $ roundTripEq (undefined :: Natural)

51 , testProperty "Natural" $ roundTripEq (undefined :: Natural)

59 , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)

52 , testProperty "Proxy" $ roundTripEq (undefined :: Proxy Int)

tests/SerializationFormatSpec.hs+23−47

@@ -3,7 +3,9 @@

3{-# LANGUAGE GADTs #-}

4{-# LANGUAGE NoImplicitPrelude #-}

5{-# LANGUAGE OverloadedStrings #-}

6+#if __GLASGOW_HASKELL__ >= 708

6{-# LANGUAGE DataKinds #-}

7{-# LANGUAGE DataKinds #-}

8+#endif

8------------------------------------------------------------------------------

10------------------------------------------------------------------------------

9-- These tests assert that the JSON serialization doesn't change by accident.

11-- These tests assert that the JSON serialization doesn't change by accident.

@@ -30,9 +32,6 @@ import Data.Proxy (Proxy(..))

30import Data.Scientific (Scientific)

32import Data.Scientific (Scientific)

31import Data.Tagged (Tagged(..))

33import Data.Tagged (Tagged(..))

32import Data.Time (fromGregorian)

34import Data.Time (fromGregorian)

33−import Data.Time.Calendar.Compat (CalendarDiffDays (..), DayOfWeek (..))

34−import Data.Time.LocalTime.Compat (CalendarDiffTime (..))

35−import Data.Time.Clock.System.Compat (SystemTime (..))

36import Data.Word (Word8)

35import Data.Word (Word8)

37import GHC.Generics (Generic)

36import GHC.Generics (Generic)

38import Instances ()

37import Instances ()

@@ -69,14 +68,13 @@ jsonExamples =

69 example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)

68 example "Either Left" "{\"Left\":1}" (Left 1 :: Either Int Int)

70 , example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)

69 , example "Either Right" "{\"Right\":1}" (Right 1 :: Either Int Int)

71 , example "Nothing" "null" (Nothing :: Maybe Int)

70 , example "Nothing" "null" (Nothing :: Maybe Int)

72− -- Maybe serialising is lossy

73− -- https://github.com/bos/aeson/issues/376

74− , Example "Just Nothing" ["null"] (Just Nothing :: Maybe (Maybe Int)) Nothing

75 , example "Just" "1" (Just 1 :: Maybe Int)

71 , example "Just" "1" (Just 1 :: Maybe Int)

76 , example "Proxy Int" "null" (Proxy :: Proxy Int)

72 , example "Proxy Int" "null" (Proxy :: Proxy Int)

77 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

73 , example "Tagged Char Int" "1" (Tagged 1 :: Tagged Char Int)

74+#if __GLASGOW_HASKELL__ >= 708

78 -- Test Tagged instance is polykinded

75 -- Test Tagged instance is polykinded

79 , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

76 , example "Tagged 123 Int" "1" (Tagged 1 :: Tagged 123 Int)

77+#endif

80 , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

78 , example "Const Char Int" "\"c\"" (Const 'c' :: Const Char Int)

81 , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

79 , example "Tuple" "[1,2]" ((1, 2) :: (Int, Int))

82 , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

80 , example "NonEmpty" "[1,2,3]" (1 :| [2, 3] :: NonEmpty Int)

@@ -84,22 +82,22 @@ jsonExamples =

84 , example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)

82 , example "DList" "[1,2,3]" (DList.fromList [1, 2, 3] :: DList.DList Int)

85 , example "()" "[]" ()

83 , example "()" "[]" ()

87− , ndExample "HashMap Int Int"

85+ , Example "HashMap Int Int"

88 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

86 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

89 (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

87 (HM.fromList [(0,1),(2,3)] :: HM.HashMap Int Int)

90− , ndExample "Map Int Int"

88+ , Example "Map Int Int"

91 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

89 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

92 (M.fromList [(0,1),(2,3)] :: M.Map Int Int)

90 (M.fromList [(0,1),(2,3)] :: M.Map Int Int)

93− , ndExample "Map (Tagged Int Int) Int"

91+ , Example "Map (Tagged Int Int) Int"

94 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

92 [ "{\"0\":1,\"2\":3}", "{\"2\":3,\"0\":1}"]

95 (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)

93 (M.fromList [(Tagged 0,1),(Tagged 2,3)] :: M.Map (Tagged Int Int) Int)

96 , example "Map [Int] Int"

94 , example "Map [Int] Int"

97 "[[[0],1],[[2],3]]"

95 "[[[0],1],[[2],3]]"

98 (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)

96 (M.fromList [([0],1),([2],3)] :: M.Map [Int] Int)

99− , ndExample "Map [Char] Int"

97+ , Example "Map [Char] Int"

100 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]

98 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]

101 (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)

99 (M.fromList [("ab",1),("cd",3)] :: M.Map String Int)

102− , ndExample "Map [I Char] Int"

100+ , Example "Map [I Char] Int"

103 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]

101 [ "{\"ab\":1,\"cd\":3}", "{\"cd\":3,\"ab\":1}" ]

104 (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)

102 (M.fromList [(map pure "ab",1),(map pure "cd",3)] :: M.Map [I Char] Int)

105

103

@@ -195,27 +193,16 @@ jsonExamples =

195 , example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)

193 , example "Semigroup.WrappedMonoid Int" "2" (Semigroup.WrapMonoid 2 :: Semigroup.WrappedMonoid Int)

196 , example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)

194 , example "Semigroup.Option Just" "2" (pure 2 :: Semigroup.Option Int)

197 , example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))

195 , example "Semigroup.Option Nothing" "null" (Semigroup.Option (Nothing :: Maybe Bool))

198−

199− -- time 1.9

200− , example "SystemTime" "123.123456789" (MkSystemTime 123 123456789)

201− , Example "SystemTime" ["124.23456789"]

202− (MkSystemTime 123 1234567890)

203− (MkSystemTime 124 234567890)

204− , ndExample "CalendarDiffTime"

205− [ "{\"months\":12,\"time\":456.789}", "{\"time\":456.789,\"months\":12}" ]

206− (CalendarDiffTime 12 456.789)

207− , ndExample "CalendarDiffDays"

208− [ "{\"months\":12,\"days\":20}", "{\"days\":20,\"months\":12}" ]

209− (CalendarDiffDays 12 20)

210− , example "DayOfWeek" "\"monday\"" Monday

211 ]

196 ]

212

197

213jsonEncodingExamples :: [Example]

198jsonEncodingExamples :: [Example]

214jsonEncodingExamples =

199jsonEncodingExamples =

215 [

200 [

201+ -- Maybe serialising is lossy

202+ -- https://github.com/bos/aeson/issues/376

203+ example "Just Nothing" "null" (Just Nothing :: Maybe (Maybe Int))

216 -- infinities cannot be recovered, null is decoded as NaN

204 -- infinities cannot be recovered, null is decoded as NaN

217− example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)

218− , example "-inf :: Double" "null" (Approx $ -1/0 :: Approx Double)

205+ , example "inf :: Double" "null" (Approx $ 1/0 :: Approx Double)

219 ]

206 ]

220

207

221jsonDecodingExamples :: [Example]

208jsonDecodingExamples :: [Example]

@@ -237,27 +224,16 @@ jsonDecodingExamples = [

237 ]

224 ]

238

225

239data Example where

226data Example where

240− Example

227+ Example

241− :: (Eq a, Show a, ToJSON a, FromJSON a)

228+ :: (Eq a, Show a, ToJSON a, FromJSON a)

242− => String -- name

243− -> [L.ByteString] -- encoded variants

244− -> a -- input

245− -> a -- decoded

246− -> Example -- empty bytestring will fail, any p [] == False

229+ => String -> [L.ByteString] -> a -> Example -- empty bytestring will fail, any p [] == False

247−

248− MaybeExample

230+ MaybeExample

249− :: (Eq a, Show a, FromJSON a)

231+ :: (Eq a, Show a, FromJSON a)

250− => String -> L.ByteString -> Maybe a -> Example

232+ => String -> L.ByteString -> Maybe a -> Example

251

233

252example :: (Eq a, Show a, ToJSON a, FromJSON a)

234example :: (Eq a, Show a, ToJSON a, FromJSON a)

253 => String -> L.ByteString -> a -> Example

235 => String -> L.ByteString -> a -> Example

254−example n bs x = Example n [bs] x x

236+example n bs x = Example n [bs] x

255−

256−-- | Non-deterministic example, input encodes to some of bytestrings.

257−ndExample :: (Eq a, Show a, ToJSON a, FromJSON a)

258− => String -> [L.ByteString] -> a -> Example

259−ndExample n bss x = Example n bss x x

260−

261

237

262data MyEither a b = MyLeft a | MyRight b

238data MyEither a b = MyLeft a | MyRight b

263 deriving (Generic, Show, Eq)

239 deriving (Generic, Show, Eq)

@@ -270,16 +246,16 @@ instance (FromJSON a, FromJSON b) => FromJSON (MyEither a b) where

270 parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

246 parseJSON = genericParseJSON defaultOptions { sumEncoding = UntaggedValue }

271

247

272assertJsonExample :: Example -> TestTree

248assertJsonExample :: Example -> TestTree

273−assertJsonExample (Example name bss val val') = testCase name $ do

249+assertJsonExample (Example name bss val) = testCase name $ do

274 assertSomeEqual "encode" bss (encode val)

250 assertSomeEqual "encode" bss (encode val)

275 assertSomeEqual "encode/via value" bss (encode $ toJSON val)

251 assertSomeEqual "encode/via value" bss (encode $ toJSON val)

276 for_ bss $ \bs ->

252 for_ bss $ \bs ->

277− assertEqual "decode" (Just val') (decode bs)

253+ assertEqual "decode" (Just val) (decode bs)

278assertJsonExample (MaybeExample name bs mval) = testCase name $

254assertJsonExample (MaybeExample name bs mval) = testCase name $

279 assertEqual "decode" mval (decode bs)

255 assertEqual "decode" mval (decode bs)

280

256

281assertJsonEncodingExample :: Example -> TestTree

257assertJsonEncodingExample :: Example -> TestTree

282−assertJsonEncodingExample (Example name bss val _) = testCase name $ do

258+assertJsonEncodingExample (Example name bss val) = testCase name $ do

283 assertSomeEqual "encode" bss (encode val)

259 assertSomeEqual "encode" bss (encode val)

284 assertSomeEqual "encode/via value" bss (encode $ toJSON val)

260 assertSomeEqual "encode/via value" bss (encode $ toJSON val)

285assertJsonEncodingExample (MaybeExample name _ _) = testCase name $

261assertJsonEncodingExample (MaybeExample name _ _) = testCase name $

tests/Types.hs+2

@@ -119,7 +119,9 @@ deriving instance Generic (Sum4 a b c d)

119deriving instance Generic (Approx a)

120deriving instance Generic Nullary

121deriving instance Generic (SomeType a)

122+#if __GLASGOW_HASKELL__ >= 706

122deriving instance Generic1 SomeType

123deriving instance Generic1 SomeType

124+#endif

123deriving instance Generic OptionField

125deriving instance Generic OptionField

124deriving instance Generic EitherTextInt

126deriving instance Generic EitherTextInt

125

127

tests/UnitTests.hs+6−164

@@ -29,44 +29,35 @@ import Data.Aeson.Internal (JSONPathElement(..), formatError)

29import Data.Aeson.QQ.Simple (aesonQQ)

30import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)

31import Data.Aeson.Text (encodeToTextBuilder)

32−import Data.Aeson.Parser

33− ( json, jsonLast, jsonAccum, jsonNoDup

34− , json', jsonLast', jsonAccum', jsonNoDup')

35−import Data.Aeson.Types

36− ( Options(..), Result(Success, Error), ToJSON(..)

37− , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2

38− , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse)

32+import Data.Aeson.Types (Options(..), Result(Success), ToJSON(..), Value(Null, Object), camelTo, camelTo2, defaultOptions, omitNothingFields, parse)

39−import Data.Attoparsec.ByteString (Parser, parseOnly)

40import Data.Char (toUpper)

33import Data.Char (toUpper)

41import Data.Either.Compat (isLeft, isRight)

34import Data.Either.Compat (isLeft, isRight)

42import Data.Hashable (hash)

35import Data.Hashable (hash)

43import Data.HashMap.Strict (HashMap)

36import Data.HashMap.Strict (HashMap)

44−import Data.List (sort, isSuffixOf)

37+import Data.List (sort)

45import Data.Maybe (fromMaybe)

38import Data.Maybe (fromMaybe)

46import Data.Scientific (Scientific, scientific)

39import Data.Scientific (Scientific, scientific)

47import Data.Tagged (Tagged(..))

40import Data.Tagged (Tagged(..))

48import Data.Text (Text)

41import Data.Text (Text)

49import Data.Time (UTCTime)

42import Data.Time (UTCTime)

50−import Data.Time.Format.Compat (parseTimeM, defaultTimeLocale)

43+import Data.Time.Format (parseTime)

44+import Data.Time.Locale.Compat (defaultTimeLocale)

51import GHC.Generics (Generic)

45import GHC.Generics (Generic)

52import Instances ()

46import Instances ()

53import Numeric.Natural (Natural)

47import Numeric.Natural (Natural)

54import System.Directory (getDirectoryContents)

48import System.Directory (getDirectoryContents)

55import System.FilePath ((</>), takeExtension, takeFileName)

49import System.FilePath ((</>), takeExtension, takeFileName)

56import Test.Tasty (TestTree, testGroup)

50import Test.Tasty (TestTree, testGroup)

57−import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase, (@?=))

51+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, assertEqual, testCase)

58import Text.Printf (printf)

52import Text.Printf (printf)

59import UnitTests.NullaryConstructors (nullaryConstructors)

53import UnitTests.NullaryConstructors (nullaryConstructors)

60−import qualified Data.ByteString as S

61import qualified Data.ByteString.Base16.Lazy as LBase16

54import qualified Data.ByteString.Base16.Lazy as LBase16

62import qualified Data.ByteString.Lazy.Char8 as L

55import qualified Data.ByteString.Lazy.Char8 as L

63import qualified Data.HashSet as HashSet

56import qualified Data.HashSet as HashSet

64−import qualified Data.HashMap.Lazy as HashMap

65import qualified Data.Text.Lazy as LT

57import qualified Data.Text.Lazy as LT

66import qualified Data.Text.Lazy.Builder as TLB

58import qualified Data.Text.Lazy.Builder as TLB

67import qualified Data.Text.Lazy.Encoding as LT

59import qualified Data.Text.Lazy.Encoding as LT

68import qualified Data.Text.Lazy.Encoding as TLE

60import qualified Data.Text.Lazy.Encoding as TLE

69−import qualified Data.Vector as Vector

70import qualified ErrorMessages

61import qualified ErrorMessages

71import qualified SerializationFormatSpec

62import qualified SerializationFormatSpec

@@ -112,12 +103,7 @@ tests = testGroup "unit" [

112 , testGroup "SingleMaybeField" singleMaybeField

103 , testGroup "SingleMaybeField" singleMaybeField

113 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

104 , testCase "withEmbeddedJSON" withEmbeddedJSONTest

114 , testCase "SingleFieldCon" singleFieldCon

105 , testCase "SingleFieldCon" singleFieldCon

115− , testGroup "UnknownFields" unknownFields

116− , testGroup "Ordering of object keys" keyOrdering

117 , testCase "Ratio with denominator 0" ratioDenominator0

106 , testCase "Ratio with denominator 0" ratioDenominator0

118− , testCase "Rational parses number" rationalNumber

119− , testCase "Big rational" bigRationalDecoding

120− , testCase "Small rational" smallRationalDecoding

121 , testCase "Big scientific exponent" bigScientificExponent

107 , testCase "Big scientific exponent" bigScientificExponent

122 , testCase "Big integer decoding" bigIntegerDecoding

108 , testCase "Big integer decoding" bigIntegerDecoding

123 , testCase "Big natural decading" bigNaturalDecoding

109 , testCase "Big natural decading" bigNaturalDecoding

@@ -229,7 +215,7 @@ utcTimeGood = do

229 where

215 where

230 parseWithRead :: String -> LT.Text -> UTCTime

216 parseWithRead :: String -> LT.Text -> UTCTime

231 parseWithRead f s =

217 parseWithRead f s =

232− fromMaybe (error "parseTime input malformed") . parseTimeM True defaultTimeLocale f . LT.unpack $ s

218+ fromMaybe (error "parseTime input malformed") . parseTime defaultTimeLocale f . LT.unpack $ s

233 parseWithAeson :: LT.Text -> Maybe UTCTime

219 parseWithAeson :: LT.Text -> Maybe UTCTime

234 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]

220 parseWithAeson s = decode . LT.encodeUtf8 $ LT.concat ["\"", s, "\""]

235

221

@@ -258,18 +244,6 @@ formatErrorExample =

258 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"

244 lhs = "Error in $[0].foo.bar['a.b.c']['']['\\'\\\\'].end: error msg"

259 in assertEqual "formatError example" lhs rhs

245 in assertEqual "formatError example" lhs rhs

260

246

261−formatPathExample :: Assertion

262−formatPathExample =

263− let rhs = formatPath [Key "x", Index 0]

264− lhs = "$.x[0]"

265− in assertEqual "formatPath example" lhs rhs

266−

267−formatRelativePathExample :: Assertion

268−formatRelativePathExample =

269− let rhs = formatPath [Key "x", Index 0]

270− lhs = ".x[0]"

271− in assertEqual "formatRelativePath example" lhs rhs

272−

273------------------------------------------------------------------------------

247------------------------------------------------------------------------------

274-- Comparison (.:?) and (.:!)

248-- Comparison (.:?) and (.:!)

275------------------------------------------------------------------------------

249------------------------------------------------------------------------------

@@ -540,7 +514,6 @@ showOptions =

540 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"

514 ++ ", sumEncoding = TaggedObject {tagFieldName = \"tag\", contentsFieldName = \"contents\"}"

541 ++ ", unwrapUnaryRecords = False"

515 ++ ", unwrapUnaryRecords = False"

542 ++ ", tagSingleConstructors = False"

516 ++ ", tagSingleConstructors = False"

543− ++ ", rejectUnknownFields = False"

544 ++ "}")

517 ++ "}")

545 (show defaultOptions)

518 (show defaultOptions)

546

519

@@ -585,138 +558,12 @@ singleFieldCon :: Assertion

585singleFieldCon =

558singleFieldCon =

586 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")

559 assertEqual "fromJSON" (Right (SingleFieldCon 0)) (eitherDecode "0")

587

560

588−newtype UnknownFields = UnknownFields { knownField :: Int }

589− deriving (Eq, Show, Generic)

590−newtype UnknownFieldsTag = UnknownFieldsTag { tag :: Int }

591− deriving (Eq, Show, Generic)

592−newtype UnknownFieldsUnaryTagged = UnknownFieldsUnaryTagged { knownFieldUnaryTagged :: Int }

593− deriving (Eq, Show, Generic)

594−data UnknownFieldsSum

595− = UnknownFields1 { knownField1 :: Int }

596− | UnknownFields2 { knownField2 :: Int }

597− deriving (Eq, Show, Generic)

598−

599−unknownFields :: [TestTree]

600−unknownFields = concat

601− [ testsUnary

602− "unary-unknown"

603− (object [("knownField", Number 1), ("unknownField", Number 1)])

604− (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFields)

605− , testsUnary

606− "unary-unknown-tag"

607− (object [("knownField", Number 1), ("tag", String "UnknownFields")])

608− (Error "nknown fields: [\"tag\"]" :: Result UnknownFields)

609− , testsUnaryTag

610− "unary-explicit-tag"

611− (object [("tag", Number 1)])

612− (Success $ UnknownFieldsTag 1)

613− , testsSum

614− "sum-tag"

615− (object [("knownField1", Number 1), ("tag", String "UnknownFields1")])

616− (Success $ UnknownFields1 1)

617− , testsSum

618− "sum-unknown-in-branch"

619− (object [("knownField1", Number 1), ("knownField2", Number 1), ("tag", String "UnknownFields1")])

620− (Error "nknown fields: [\"knownField2\"]" :: Result UnknownFieldsSum)

621− , testsSum

622− "sum-unknown"

623− (object [("knownField1", Number 1), ("unknownField", Number 1), ("tag", String "UnknownFields1")])

624− (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsSum)

625− , testsTagged

626− "unary-tagged"

627− (object [("knownFieldUnaryTagged", Number 1), ("tag", String "UnknownFieldsUnaryTagged")])

628− (Success $ UnknownFieldsUnaryTagged 1)

629− , -- Just a case to verify that the tag isn't optional, this is likely already tested by other unit tests

630− testsTagged

631− "unary-tagged-notag"

632− (object [("knownFieldUnaryTagged", Number 1)])

633− (Error "key \"tag\" not found" :: Result UnknownFieldsUnaryTagged)

634− , testsTagged

635− "unary-tagged-unknown"

636− (object [ ("knownFieldUnaryTagged", Number 1), ("unknownField", Number 1)

637− , ("tag", String "UnknownFieldsUnaryTagged")])

638− (Error "nknown fields: [\"unknownField\"]" :: Result UnknownFieldsUnaryTagged)

639− ]

640− where

641− opts = defaultOptions{rejectUnknownFields=True}

642− taggedOpts = opts{tagSingleConstructors=True}

643− assertApprox :: (Show a, Eq a) => Result a -> Result a -> IO ()

644− assertApprox (Error expected) (Error actual) | expected `isSuffixOf` actual = return ()

645− assertApprox expected actual = assertEqual "fromJSON" expected actual

646− testsBase :: (Show a, Eq a) => (Value -> Result a) -> (Value -> Result a)

647− -> String -> Value -> Result a -> [TestTree]

648− testsBase th g name value expected =

649− [ testCase (name ++ "-th") $ assertApprox expected (th value)

650− , testCase (name ++ "-generic") $ assertApprox expected (g value)

651− ]

652− testsUnary :: String -> Value -> Result UnknownFields -> [TestTree]

653− testsUnary = testsBase fromJSON (parse (genericParseJSON opts))

654− testsUnaryTag :: String -> Value -> Result UnknownFieldsTag -> [TestTree]

655− testsUnaryTag = testsBase fromJSON (parse (genericParseJSON opts))

656− testsSum :: String -> Value -> Result UnknownFieldsSum -> [TestTree]

657− testsSum = testsBase fromJSON (parse (genericParseJSON opts))

658− testsTagged :: String -> Value -> Result UnknownFieldsUnaryTagged -> [TestTree]

659− testsTagged = testsBase fromJSON (parse (genericParseJSON taggedOpts))

660−

661−testParser :: (Eq a, Show a)

662− => String -> Parser a -> S.ByteString -> Either String a -> TestTree

663−testParser name json_ s expected =

664− testCase name (parseOnly json_ s @?= expected)

665−

666−keyOrdering :: [TestTree]

667−keyOrdering =

668− [ testParser "json" json

669− "{\"k\":true,\"k\":false}" $

670− Right (Object (HashMap.fromList [("k", Bool True)]))

671− , testParser "jsonLast" jsonLast

672− "{\"k\":true,\"k\":false}" $

673− Right (Object (HashMap.fromList [("k", Bool False)]))

674− , testParser "jsonAccum" jsonAccum

675− "{\"k\":true,\"k\":false}" $

676− Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))]))

677− , testParser "jsonNoDup" jsonNoDup

678− "{\"k\":true,\"k\":false}" $

679− Left "Failed reading: found duplicate key: \"k\""

680−

681− , testParser "json'" json'

682− "{\"k\":true,\"k\":false}" $

683− Right (Object (HashMap.fromList [("k", Bool True)]))

684− , testParser "jsonLast'" jsonLast'

685− "{\"k\":true,\"k\":false}" $

686− Right (Object (HashMap.fromList [("k", Bool False)]))

687− , testParser "jsonAccum'" jsonAccum'

688− "{\"k\":true,\"k\":false}" $

689− Right (Object (HashMap.fromList [("k", Array (Vector.fromList [Bool True, Bool False]))]))

690− , testParser "jsonNoDup'" jsonNoDup'

691− "{\"k\":true,\"k\":false}" $

692− Left "Failed reading: found duplicate key: \"k\""

693− ]

694−

695ratioDenominator0 :: Assertion

561ratioDenominator0 :: Assertion

696ratioDenominator0 =

562ratioDenominator0 =

697 assertEqual "Ratio with denominator 0"

563 assertEqual "Ratio with denominator 0"

698 (Left "Error in $: Ratio denominator was 0")

564 (Left "Error in $: Ratio denominator was 0")

699 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)

565 (eitherDecode "{ \"numerator\": 1, \"denominator\": 0 }" :: Either String Rational)

700

566

701−rationalNumber :: Assertion

702−rationalNumber =

703− assertEqual "Ratio with denominator 0"

704− (Right 1.37)

705− (eitherDecode "1.37" :: Either String Rational)

706−

707−bigRationalDecoding :: Assertion

708−bigRationalDecoding =

709− assertEqual "Decoding an Integer with a large exponent should fail"

710− (Left "Error in $: parsing Ratio failed, found a number with exponent 2000, but it must not be greater than 1024 or less than -1024")

711− ((eitherDecode :: L.ByteString -> Either String Rational) "1e2000")

712−

713−smallRationalDecoding :: Assertion

714−smallRationalDecoding =

715− assertEqual "Decoding an Integer with a large exponent should fail"

716− (Left "Error in $: parsing Ratio failed, found a number with exponent -2000, but it must not be greater than 1024 or less than -1024")

717− ((eitherDecode :: L.ByteString -> Either String Rational) "1e-2000")

718−

719−

720bigScientificExponent :: Assertion

567bigScientificExponent :: Assertion

721bigScientificExponent =

568bigScientificExponent =

722 assertEqual "Encoding an integral scientific with a large exponent should normalize it"

569 assertEqual "Encoding an integral scientific with a large exponent should normalize it"

@@ -753,8 +600,3 @@ deriveToJSON defaultOptions ''Foo

753deriveToJSON1 defaultOptions ''Foo

600deriveToJSON1 defaultOptions ''Foo

754

601

755deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField

602deriveJSON defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True} ''SingleMaybeField

756−

757−deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFields

758−deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsTag

759−deriveJSON defaultOptions{tagSingleConstructors=True,rejectUnknownFields=True} ''UnknownFieldsUnaryTagged

760−deriveJSON defaultOptions{rejectUnknownFields=True} ''UnknownFieldsSum

tests/UnitTests/NullaryConstructors.hs−5

@@ -14,7 +14,6 @@ import Data.Aeson (decode, eitherDecode, fromEncoding, Value)

14import Data.Aeson.Internal (IResult (..), iparse)

15import Data.Aeson.Types (Parser)

16import Data.ByteString.Builder (toLazyByteString)

17−import Data.Foldable (for_)

18import Data.Maybe (fromJust)

17import Data.Maybe (fromJust)

19import Encoders

18import Encoders

20import Test.Tasty.HUnit ((@=?), Assertion)

19import Test.Tasty.HUnit ((@=?), Assertion)

@@ -53,10 +52,6 @@ nullaryConstructors =

53 -- Make sure that the old `"contents" : []' is still allowed

52 -- Make sure that the old `"contents" : []' is still allowed

54 , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

53 , ISuccess C1 @=? parse thNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

55 , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

54 , ISuccess C1 @=? parse gNullaryParseJSONTaggedObject (dec "{\"tag\":\"c1\",\"contents\":[]}")

56−

57− , for_ [("kC1", C1), ("kC2", C2), ("kC3", C3)] $ \(jkey, key) -> do

58− Right jkey @=? gNullaryToJSONKey key

59− ISuccess key @=? parse gNullaryFromJSONKey jkey

60 ]

55 ]

61 where

56 where

62 enc = eitherDecode . toLazyByteString . fromEncoding

57 enc = eitherDecode . toLazyByteString . fromEncoding

tests/golden/generic.expecteddeleted−48

@@ -1,48 +0,0 @@

1−OneConstructor

2−Error in $: parsing Types.OneConstructor(OneConstructor) failed, expected Array, but encountered String

3−Error in $: parsing Types.OneConstructor(OneConstructor) failed, expected an empty Array, but encountered an Array of length 1

4−Nullary

5−Error in $: parsing Types.Nullary failed, expected one of the tags ["C1","C2","C3"], but found tag "X"

6−Error in $: parsing Types.Nullary failed, expected String, but encountered Array

7−SomeType (tagged)

8−Error in $.contents: parsing Int failed, expected Number, but encountered Boolean

9−Error in $: parsing Types.SomeType(Unary) failed, key "contents" not found

10−Error in $: parsing Types.SomeType(Record) failed, key "testone" not found

11−Error in $.testone: parsing Double failed, unexpected Boolean

12−Error in $.tag: parsing Types.SomeType failed, expected tag field to be one of ["nullary","unary","product","record","list"], but found tag "X"

13−Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found

14−Error in $: parsing Types.SomeType failed, expected Object, but encountered Array

15−SomeType (single-field)

16−Error in $.unary: parsing Int failed, expected Number, but encountered Object

17−Error in $.unary: parsing Int failed, expected Number, but encountered Array

18−Error in $: parsing Types.SomeType failed, expected an Object with a single pair where the tag is one of ["nullary","unary","product","record","list"], but found tag "X"

19−Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 2 pairs

20−Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 0 pairs

21−Error in $: parsing Types.SomeType failed, expected Object, but encountered Array

22−Error in $: not enough input. Expecting ':'

23−Error in $: not enough input. Expecting object value

24−Error in $: not enough input. Expecting ',' or '}'

25−SomeType (two-element array)

26−Error in $[1]: parsing Int failed, expected Number, but encountered Boolean

27−Error in $[1]: parsing Types.SomeType(Record) failed, expected Object, but encountered Null

28−Error in $[0]: parsing Types.SomeType failed, expected tag of the 2-element Array to be one of ["nullary","unary","product","record","list"], but found tag "X"

29−Error in $[0]: parsing Types.SomeType failed, tag element is not a String

30−Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encountered an Array of length 0

31−Error in $: parsing Types.SomeType failed, expected Array, but encountered Object

32−Error in $: not enough input. Expecting ',' or ']'

33−Error in $: not enough input. Expecting json list value

34−SomeType (reject unknown fields)

35−Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testZero"]

36−Error in $: parsing Types.SomeType failed, expected Object with key "tag" containing one of ["nullary","unary","product","record","list"], key "tag" not found

37−Error in $: parsing Types.SomeType(Record) failed, unknown fields: ["testtwo","testone","testthree"]

38−Foo (reject unknown fields)

39−Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["tag"]

40−Foo (reject unknown fields, tagged single)

41−Error in $: parsing Types.Foo(Foo) failed, unknown fields: ["unknownField"]

42−EitherTextInt

43−Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X"

44−Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array

45−Product2 Int Bool

46−Error in $[1]: expected Bool, but encountered Null

47−Error in $: parsing Types.Product2(Product2) failed, expected an Array of length 2, but encountered an Array of length 0

48−Error in $: parsing Types.Product2(Product2) failed, expected Array, but encountered Object

travis/cabal_macros.hdeleted−448

@@ -1,448 +0,0 @@

1−/* DO NOT EDIT: This file is automatically generated by Cabal */

2−

3−/* package aeson-1.4.4.0 */

4−#ifndef VERSION_aeson

5−#define VERSION_aeson "1.4.4.0"

6−#endif /* VERSION_aeson */

7−#ifndef MIN_VERSION_aeson

8−#define MIN_VERSION_aeson(major1,major2,minor) (\

9− (major1) < 1 || \

10− (major1) == 1 && (major2) < 4 || \

11− (major1) == 1 && (major2) == 4 && (minor) <= 4)

12−#endif /* MIN_VERSION_aeson */

13−

14−/* package Diff-0.3.4 */

15−#ifndef VERSION_Diff

16−#define VERSION_Diff "0.3.4"

17−#endif /* VERSION_Diff */

18−#ifndef MIN_VERSION_Diff

19−#define MIN_VERSION_Diff(major1,major2,minor) (\

20− (major1) < 0 || \

21− (major1) == 0 && (major2) < 3 || \

22− (major1) == 0 && (major2) == 3 && (minor) <= 4)

23−#endif /* MIN_VERSION_Diff */

24−

25−/* package QuickCheck-2.13.1 */

26−#ifndef VERSION_QuickCheck

27−#define VERSION_QuickCheck "2.13.1"

28−#endif /* VERSION_QuickCheck */

29−#ifndef MIN_VERSION_QuickCheck

30−#define MIN_VERSION_QuickCheck(major1,major2,minor) (\

31− (major1) < 2 || \

32− (major1) == 2 && (major2) < 13 || \

33− (major1) == 2 && (major2) == 13 && (minor) <= 1)

34−#endif /* MIN_VERSION_QuickCheck */

35−

36−/* package aeson-1.4.4.0 */

37−#ifndef VERSION_aeson

38−#define VERSION_aeson "1.4.4.0"

39−#endif /* VERSION_aeson */

40−#ifndef MIN_VERSION_aeson

41−#define MIN_VERSION_aeson(major1,major2,minor) (\

42− (major1) < 1 || \

43− (major1) == 1 && (major2) < 4 || \

44− (major1) == 1 && (major2) == 4 && (minor) <= 4)

45−#endif /* MIN_VERSION_aeson */

46−

47−/* package attoparsec-0.13.2.2 */

48−#ifndef VERSION_attoparsec

49−#define VERSION_attoparsec "0.13.2.2"

50−#endif /* VERSION_attoparsec */

51−#ifndef MIN_VERSION_attoparsec

52−#define MIN_VERSION_attoparsec(major1,major2,minor) (\

53− (major1) < 0 || \

54− (major1) == 0 && (major2) < 13 || \

55− (major1) == 0 && (major2) == 13 && (minor) <= 2)

56−#endif /* MIN_VERSION_attoparsec */

57−

58−/* package base-4.12.0.0 */

59−#ifndef VERSION_base

60−#define VERSION_base "4.12.0.0"

61−#endif /* VERSION_base */

62−#ifndef MIN_VERSION_base

63−#define MIN_VERSION_base(major1,major2,minor) (\

64− (major1) < 4 || \

65− (major1) == 4 && (major2) < 12 || \

66− (major1) == 4 && (major2) == 12 && (minor) <= 0)

67−#endif /* MIN_VERSION_base */

68−

69−/* package base-compat-0.10.5 */

70−#ifndef VERSION_base_compat

71−#define VERSION_base_compat "0.10.5"

72−#endif /* VERSION_base_compat */

73−#ifndef MIN_VERSION_base_compat

74−#define MIN_VERSION_base_compat(major1,major2,minor) (\

75− (major1) < 0 || \

76− (major1) == 0 && (major2) < 10 || \

77− (major1) == 0 && (major2) == 10 && (minor) <= 5)

78−#endif /* MIN_VERSION_base_compat */

79−

80−/* package base-orphans-0.8.1 */

81−#ifndef VERSION_base_orphans

82−#define VERSION_base_orphans "0.8.1"

83−#endif /* VERSION_base_orphans */

84−#ifndef MIN_VERSION_base_orphans

85−#define MIN_VERSION_base_orphans(major1,major2,minor) (\

86− (major1) < 0 || \

87− (major1) == 0 && (major2) < 8 || \

88− (major1) == 0 && (major2) == 8 && (minor) <= 1)

89−#endif /* MIN_VERSION_base_orphans */

90−

91−/* package base16-bytestring-0.1.1.6 */

92−#ifndef VERSION_base16_bytestring

93−#define VERSION_base16_bytestring "0.1.1.6"

94−#endif /* VERSION_base16_bytestring */

95−#ifndef MIN_VERSION_base16_bytestring

96−#define MIN_VERSION_base16_bytestring(major1,major2,minor) (\

97− (major1) < 0 || \

98− (major1) == 0 && (major2) < 1 || \

99− (major1) == 0 && (major2) == 1 && (minor) <= 1)

100−#endif /* MIN_VERSION_base16_bytestring */

101−

102−/* package bytestring-0.10.8.2 */

103−#ifndef VERSION_bytestring

104−#define VERSION_bytestring "0.10.8.2"

105−#endif /* VERSION_bytestring */

106−#ifndef MIN_VERSION_bytestring

107−#define MIN_VERSION_bytestring(major1,major2,minor) (\

108− (major1) < 0 || \

109− (major1) == 0 && (major2) < 10 || \

110− (major1) == 0 && (major2) == 10 && (minor) <= 8)

111−#endif /* MIN_VERSION_bytestring */

112−

113−/* package containers-0.6.0.1 */

114−#ifndef VERSION_containers

115−#define VERSION_containers "0.6.0.1"

116−#endif /* VERSION_containers */

117−#ifndef MIN_VERSION_containers

118−#define MIN_VERSION_containers(major1,major2,minor) (\

119− (major1) < 0 || \

120− (major1) == 0 && (major2) < 6 || \

121− (major1) == 0 && (major2) == 6 && (minor) <= 0)

122−#endif /* MIN_VERSION_containers */

123−

124−/* package directory-1.3.3.0 */

125−#ifndef VERSION_directory

126−#define VERSION_directory "1.3.3.0"

127−#endif /* VERSION_directory */

128−#ifndef MIN_VERSION_directory

129−#define MIN_VERSION_directory(major1,major2,minor) (\

130− (major1) < 1 || \

131− (major1) == 1 && (major2) < 3 || \

132− (major1) == 1 && (major2) == 3 && (minor) <= 3)

133−#endif /* MIN_VERSION_directory */

134−

135−/* package dlist-0.8.0.6 */

136−#ifndef VERSION_dlist

137−#define VERSION_dlist "0.8.0.6"

138−#endif /* VERSION_dlist */

139−#ifndef MIN_VERSION_dlist

140−#define MIN_VERSION_dlist(major1,major2,minor) (\

141− (major1) < 0 || \

142− (major1) == 0 && (major2) < 8 || \

143− (major1) == 0 && (major2) == 8 && (minor) <= 0)

144−#endif /* MIN_VERSION_dlist */

145−

146−/* package filepath-1.4.2.1 */

147−#ifndef VERSION_filepath

148−#define VERSION_filepath "1.4.2.1"

149−#endif /* VERSION_filepath */

150−#ifndef MIN_VERSION_filepath

151−#define MIN_VERSION_filepath(major1,major2,minor) (\

152− (major1) < 1 || \

153− (major1) == 1 && (major2) < 4 || \

154− (major1) == 1 && (major2) == 4 && (minor) <= 2)

155−#endif /* MIN_VERSION_filepath */

156−

157−/* package generic-deriving-1.12.4 */

158−#ifndef VERSION_generic_deriving

159−#define VERSION_generic_deriving "1.12.4"

160−#endif /* VERSION_generic_deriving */

161−#ifndef MIN_VERSION_generic_deriving

162−#define MIN_VERSION_generic_deriving(major1,major2,minor) (\

163− (major1) < 1 || \

164− (major1) == 1 && (major2) < 12 || \

165− (major1) == 1 && (major2) == 12 && (minor) <= 4)

166−#endif /* MIN_VERSION_generic_deriving */

167−

168−/* package ghc-prim-0.5.3 */

169−#ifndef VERSION_ghc_prim

170−#define VERSION_ghc_prim "0.5.3"

171−#endif /* VERSION_ghc_prim */

172−#ifndef MIN_VERSION_ghc_prim

173−#define MIN_VERSION_ghc_prim(major1,major2,minor) (\

174− (major1) < 0 || \

175− (major1) == 0 && (major2) < 5 || \

176− (major1) == 0 && (major2) == 5 && (minor) <= 3)

177−#endif /* MIN_VERSION_ghc_prim */

178−

179−/* package hashable-1.3.0.0 */

180−#ifndef VERSION_hashable

181−#define VERSION_hashable "1.3.0.0"

182−#endif /* VERSION_hashable */

183−#ifndef MIN_VERSION_hashable

184−#define MIN_VERSION_hashable(major1,major2,minor) (\

185− (major1) < 1 || \

186− (major1) == 1 && (major2) < 3 || \

187− (major1) == 1 && (major2) == 3 && (minor) <= 0)

188−#endif /* MIN_VERSION_hashable */

189−

190−/* package hashable-time-0.2.0.2 */

191−#ifndef VERSION_hashable_time

192−#define VERSION_hashable_time "0.2.0.2"

193−#endif /* VERSION_hashable_time */

194−#ifndef MIN_VERSION_hashable_time

195−#define MIN_VERSION_hashable_time(major1,major2,minor) (\

196− (major1) < 0 || \

197− (major1) == 0 && (major2) < 2 || \

198− (major1) == 0 && (major2) == 2 && (minor) <= 0)

199−#endif /* MIN_VERSION_hashable_time */

200−

201−/* package integer-logarithms-1.0.3 */

202−#ifndef VERSION_integer_logarithms

203−#define VERSION_integer_logarithms "1.0.3"

204−#endif /* VERSION_integer_logarithms */

205−#ifndef MIN_VERSION_integer_logarithms

206−#define MIN_VERSION_integer_logarithms(major1,major2,minor) (\

207− (major1) < 1 || \

208− (major1) == 1 && (major2) < 0 || \

209− (major1) == 1 && (major2) == 0 && (minor) <= 3)

210−#endif /* MIN_VERSION_integer_logarithms */

211−

212−/* package quickcheck-instances-0.3.21 */

213−#ifndef VERSION_quickcheck_instances

214−#define VERSION_quickcheck_instances "0.3.21"

215−#endif /* VERSION_quickcheck_instances */

216−#ifndef MIN_VERSION_quickcheck_instances

217−#define MIN_VERSION_quickcheck_instances(major1,major2,minor) (\

218− (major1) < 0 || \

219− (major1) == 0 && (major2) < 3 || \

220− (major1) == 0 && (major2) == 3 && (minor) <= 21)

221−#endif /* MIN_VERSION_quickcheck_instances */

222−

223−/* package scientific-0.3.6.2 */

224−#ifndef VERSION_scientific

225−#define VERSION_scientific "0.3.6.2"

226−#endif /* VERSION_scientific */

227−#ifndef MIN_VERSION_scientific

228−#define MIN_VERSION_scientific(major1,major2,minor) (\

229− (major1) < 0 || \

230− (major1) == 0 && (major2) < 3 || \

231− (major1) == 0 && (major2) == 3 && (minor) <= 6)

232−#endif /* MIN_VERSION_scientific */

233−

234−/* package tagged-0.8.6 */

235−#ifndef VERSION_tagged

236−#define VERSION_tagged "0.8.6"

237−#endif /* VERSION_tagged */

238−#ifndef MIN_VERSION_tagged

239−#define MIN_VERSION_tagged(major1,major2,minor) (\

240− (major1) < 0 || \

241− (major1) == 0 && (major2) < 8 || \

242− (major1) == 0 && (major2) == 8 && (minor) <= 6)

243−#endif /* MIN_VERSION_tagged */

244−

245−/* package tasty-1.2.3 */

246−#ifndef VERSION_tasty

247−#define VERSION_tasty "1.2.3"

248−#endif /* VERSION_tasty */

249−#ifndef MIN_VERSION_tasty

250−#define MIN_VERSION_tasty(major1,major2,minor) (\

251− (major1) < 1 || \

252− (major1) == 1 && (major2) < 2 || \

253− (major1) == 1 && (major2) == 2 && (minor) <= 3)

254−#endif /* MIN_VERSION_tasty */

255−

256−/* package tasty-golden-2.3.2 */

257−#ifndef VERSION_tasty_golden

258−#define VERSION_tasty_golden "2.3.2"

259−#endif /* VERSION_tasty_golden */

260−#ifndef MIN_VERSION_tasty_golden

261−#define MIN_VERSION_tasty_golden(major1,major2,minor) (\

262− (major1) < 2 || \

263− (major1) == 2 && (major2) < 3 || \

264− (major1) == 2 && (major2) == 3 && (minor) <= 2)

265−#endif /* MIN_VERSION_tasty_golden */

266−

267−/* package tasty-hunit-0.10.0.2 */

268−#ifndef VERSION_tasty_hunit

269−#define VERSION_tasty_hunit "0.10.0.2"

270−#endif /* VERSION_tasty_hunit */

271−#ifndef MIN_VERSION_tasty_hunit

272−#define MIN_VERSION_tasty_hunit(major1,major2,minor) (\

273− (major1) < 0 || \

274− (major1) == 0 && (major2) < 10 || \

275− (major1) == 0 && (major2) == 10 && (minor) <= 0)

276−#endif /* MIN_VERSION_tasty_hunit */

277−

278−/* package tasty-quickcheck-0.10.1 */

279−#ifndef VERSION_tasty_quickcheck

280−#define VERSION_tasty_quickcheck "0.10.1"

281−#endif /* VERSION_tasty_quickcheck */

282−#ifndef MIN_VERSION_tasty_quickcheck

283−#define MIN_VERSION_tasty_quickcheck(major1,major2,minor) (\

284− (major1) < 0 || \

285− (major1) == 0 && (major2) < 10 || \

286− (major1) == 0 && (major2) == 10 && (minor) <= 1)

287−#endif /* MIN_VERSION_tasty_quickcheck */

288−

289−/* package template-haskell-2.14.0.0 */

290−#ifndef VERSION_template_haskell

291−#define VERSION_template_haskell "2.14.0.0"

292−#endif /* VERSION_template_haskell */

293−#ifndef MIN_VERSION_template_haskell

294−#define MIN_VERSION_template_haskell(major1,major2,minor) (\

295− (major1) < 2 || \

296− (major1) == 2 && (major2) < 14 || \

297− (major1) == 2 && (major2) == 14 && (minor) <= 0)

298−#endif /* MIN_VERSION_template_haskell */

299−

300−/* package text-1.2.3.1 */

301−#ifndef VERSION_text

302−#define VERSION_text "1.2.3.1"

303−#endif /* VERSION_text */

304−#ifndef MIN_VERSION_text

305−#define MIN_VERSION_text(major1,major2,minor) (\

306− (major1) < 1 || \

307− (major1) == 1 && (major2) < 2 || \

308− (major1) == 1 && (major2) == 2 && (minor) <= 3)

309−#endif /* MIN_VERSION_text */

310−

311−/* package time-1.8.0.2 */

312−#ifndef VERSION_time

313−#define VERSION_time "1.8.0.2"

314−#endif /* VERSION_time */

315−#ifndef MIN_VERSION_time

316−#define MIN_VERSION_time(major1,major2,minor) (\

317− (major1) < 1 || \

318− (major1) == 1 && (major2) < 8 || \

319− (major1) == 1 && (major2) == 8 && (minor) <= 0)

320−#endif /* MIN_VERSION_time */

321−

322−/* package time-compat-1.9.2.2 */

323−#ifndef VERSION_time_compat

324−#define VERSION_time_compat "1.9.2.2"

325−#endif /* VERSION_time_compat */

326−#ifndef MIN_VERSION_time_compat

327−#define MIN_VERSION_time_compat(major1,major2,minor) (\

328− (major1) < 1 || \

329− (major1) == 1 && (major2) < 9 || \

330− (major1) == 1 && (major2) == 9 && (minor) <= 2)

331−#endif /* MIN_VERSION_time_compat */

332−

333−/* package unordered-containers-0.2.10.0 */

334−#ifndef VERSION_unordered_containers

335−#define VERSION_unordered_containers "0.2.10.0"

336−#endif /* VERSION_unordered_containers */

337−#ifndef MIN_VERSION_unordered_containers

338−#define MIN_VERSION_unordered_containers(major1,major2,minor) (\

339− (major1) < 0 || \

340− (major1) == 0 && (major2) < 2 || \

341− (major1) == 0 && (major2) == 2 && (minor) <= 10)

342−#endif /* MIN_VERSION_unordered_containers */

343−

344−/* package uuid-types-1.0.3 */

345−#ifndef VERSION_uuid_types

346−#define VERSION_uuid_types "1.0.3"

347−#endif /* VERSION_uuid_types */

348−#ifndef MIN_VERSION_uuid_types

349−#define MIN_VERSION_uuid_types(major1,major2,minor) (\

350− (major1) < 1 || \

351− (major1) == 1 && (major2) < 0 || \

352− (major1) == 1 && (major2) == 0 && (minor) <= 3)

353−#endif /* MIN_VERSION_uuid_types */

354−

355−/* package vector-0.12.0.3 */

356−#ifndef VERSION_vector

357−#define VERSION_vector "0.12.0.3"

358−#endif /* VERSION_vector */

359−#ifndef MIN_VERSION_vector

360−#define MIN_VERSION_vector(major1,major2,minor) (\

361− (major1) < 0 || \

362− (major1) == 0 && (major2) < 12 || \

363− (major1) == 0 && (major2) == 12 && (minor) <= 0)

364−#endif /* MIN_VERSION_vector */

365−

366−/* tool gcc-4.2.1 */

367−#ifndef TOOL_VERSION_gcc

368−#define TOOL_VERSION_gcc "4.2.1"

369−#endif /* TOOL_VERSION_gcc */

370−#ifndef MIN_TOOL_VERSION_gcc

371−#define MIN_TOOL_VERSION_gcc(major1,major2,minor) (\

372− (major1) < 4 || \

373− (major1) == 4 && (major2) < 2 || \

374− (major1) == 4 && (major2) == 2 && (minor) <= 1)

375−#endif /* MIN_TOOL_VERSION_gcc */

376−

377−/* tool ghc-8.6.5 */

378−#ifndef TOOL_VERSION_ghc

379−#define TOOL_VERSION_ghc "8.6.5"

380−#endif /* TOOL_VERSION_ghc */

381−#ifndef MIN_TOOL_VERSION_ghc

382−#define MIN_TOOL_VERSION_ghc(major1,major2,minor) (\

383− (major1) < 8 || \

384− (major1) == 8 && (major2) < 6 || \

385− (major1) == 8 && (major2) == 6 && (minor) <= 5)

386−#endif /* MIN_TOOL_VERSION_ghc */

387−

388−/* tool ghc-pkg-8.6.5 */

389−#ifndef TOOL_VERSION_ghc_pkg

390−#define TOOL_VERSION_ghc_pkg "8.6.5"

391−#endif /* TOOL_VERSION_ghc_pkg */

392−#ifndef MIN_TOOL_VERSION_ghc_pkg

393−#define MIN_TOOL_VERSION_ghc_pkg(major1,major2,minor) (\

394− (major1) < 8 || \

395− (major1) == 8 && (major2) < 6 || \

396− (major1) == 8 && (major2) == 6 && (minor) <= 5)

397−#endif /* MIN_TOOL_VERSION_ghc_pkg */

398−

399−/* tool haddock-2.22.0 */

400−#ifndef TOOL_VERSION_haddock

401−#define TOOL_VERSION_haddock "2.22.0"

402−#endif /* TOOL_VERSION_haddock */

403−#ifndef MIN_TOOL_VERSION_haddock

404−#define MIN_TOOL_VERSION_haddock(major1,major2,minor) (\

405− (major1) < 2 || \

406− (major1) == 2 && (major2) < 22 || \

407− (major1) == 2 && (major2) == 22 && (minor) <= 0)

408−#endif /* MIN_TOOL_VERSION_haddock */

409−

410−/* tool hpc-0.67 */

411−#ifndef TOOL_VERSION_hpc

412−#define TOOL_VERSION_hpc "0.67"

413−#endif /* TOOL_VERSION_hpc */

414−#ifndef MIN_TOOL_VERSION_hpc

415−#define MIN_TOOL_VERSION_hpc(major1,major2,minor) (\

416− (major1) < 0 || \

417− (major1) == 0 && (major2) < 67 || \

418− (major1) == 0 && (major2) == 67 && (minor) <= 0)

419−#endif /* MIN_TOOL_VERSION_hpc */

420−

421−/* tool hsc2hs-0.68.5 */

422−#ifndef TOOL_VERSION_hsc2hs

423−#define TOOL_VERSION_hsc2hs "0.68.5"

424−#endif /* TOOL_VERSION_hsc2hs */

425−#ifndef MIN_TOOL_VERSION_hsc2hs

426−#define MIN_TOOL_VERSION_hsc2hs(major1,major2,minor) (\

427− (major1) < 0 || \

428− (major1) == 0 && (major2) < 68 || \

429− (major1) == 0 && (major2) == 68 && (minor) <= 5)

430−#endif /* MIN_TOOL_VERSION_hsc2hs */

431−

432−/* tool runghc-8.6.5 */

433−#ifndef TOOL_VERSION_runghc

434−#define TOOL_VERSION_runghc "8.6.5"

435−#endif /* TOOL_VERSION_runghc */

436−#ifndef MIN_TOOL_VERSION_runghc

437−#define MIN_TOOL_VERSION_runghc(major1,major2,minor) (\

438− (major1) < 8 || \

439− (major1) == 8 && (major2) < 6 || \

440− (major1) == 8 && (major2) == 6 && (minor) <= 5)

441−#endif /* MIN_TOOL_VERSION_runghc */

442−

443−#ifndef CURRENT_COMPONENT_ID

444−#define CURRENT_COMPONENT_ID "aeson-1.4.4.0-inplace-tests"

445−#endif /* CURRENT_COMPONENT_ID */

446−#ifndef CURRENT_PACKAGE_VERSION

447−#define CURRENT_PACKAGE_VERSION "1.4.4.0"

448−#endif /* CURRENT_PACKAGE_VERSION */

travis/install.sh−11

@@ -7,11 +7,6 @@ echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo

7stack --version

9case $BUILD in

10− hlint)

11− echo "Downloading hlint"

12− curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh > hlint.sh

13− chmod +x hlint.sh

14− ;;

15 stack)

10 stack)

16 stack --no-terminal --skip-ghc-check setup

11 stack --no-terminal --skip-ghc-check setup

17 stack --no-terminal --skip-ghc-check test --only-snapshot

12 stack --no-terminal --skip-ghc-check test --only-snapshot

@@ -49,10 +44,4 @@ case $BUILD in

49 cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

44 cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;

50 fi

45 fi

51 ;;

46 ;;

52− cabal2)

53− cabal v2-update -v

54− sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config

55−

56− cabal v2-build --only-dependencies --enable-tests --enable-benchmarks --dry

57− ;;

58esac

47esac

travis/script.sh+2−4

@@ -19,11 +19,9 @@ case $BUILD in

19 SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&

20 (cd dist && cabal install --force-reinstalls "$SRC_TGZ")

21 ;;

22− cabal2)

23− cabal v2-build --enable-tests --enable-benchmarks

24− cabal v2-test --enable-tests --enable-benchmarks

25− ;;

26 hlint)

22 hlint)

23+ stack build --fast aeson --stack-yaml stack-nightly.yaml --system-ghc --no-terminal

24+ stack install hlint --stack-yaml stack-nightly.yaml --system-ghc --no-terminal

27 make lint

25 make lint

28 ;;

26 ;;

29esac

27esac