Skip to content

Commit fe3c101

Browse files
bergmarkbergmark
authored
Merge pull request #636 from Lysxia/better-error-messages
Improve error messages
2 parents 2532376 + 2d4d85e commit fe3c101

File tree

11 files changed

+828
-409
lines changed

11 files changed

+828
-409
lines changed

‎Data/Aeson/Types.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ module Data.Aeson.Types
2626
-- * Convenience types and functions
2727
, DotNetTime(..)
2828
, typeMismatch
29+
, unexpected
2930
-- * Type conversion
3031
, Parser
3132
, Result(..)
@@ -37,6 +38,7 @@ module Data.Aeson.Types
3738
, ToJSON(..)
3839
, KeyValue(..)
3940
, modifyFailure
41+
, prependFailure
4042
, parserThrowError
4143
, parserCatchError
4244

‎Data/Aeson/Types/Class.hs‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -79,6 +79,7 @@ module Data.Aeson.Types.Class
7979
, fromJSON
8080
, ifromJSON
8181
, typeMismatch
82+
, unexpected
8283
, parseField
8384
, parseFieldMaybe
8485
, parseFieldMaybe'

‎Data/Aeson/Types/FromJSON.hs‎

Lines changed: 556 additions & 330 deletions
Large diffs are not rendered by default.

‎Data/Aeson/Types/Generic.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE CPP #-}
22
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE DeriveFunctor #-}
34
{-# LANGUAGE EmptyDataDecls #-}
45
{-# LANGUAGE FlexibleInstances #-}
56
{-# LANGUAGE FunctionalDependencies #-}
@@ -35,6 +36,7 @@ module Data.Aeson.Types.Generic
3536
, Zero
3637
, One
3738
, ProductSize(..)
39+
, (:*)(..)
3840
) where
3941

4042
import Prelude.Compat
@@ -75,6 +77,7 @@ instance AllNullary (Rec1 f) False
7577
instance AllNullary U1 True
7678

7779
newtype Tagged2 (s :: * -> *) b = Tagged2 {unTagged2 :: b}
80+
deriving Functor
7881

7982
--------------------------------------------------------------------------------
8083

@@ -107,3 +110,10 @@ instance (ProductSize a, ProductSize b) => ProductSize (a :*: b) where
107110

108111
instance ProductSize (S1 s a) where
109112
productSize = Tagged2 1
113+
114+
--------------------------------------------------------------------------------
115+
116+
-- | Simple extensible tuple type to simplify passing around many parameters.
117+
data a :* b = a :* b
118+
119+
infixr 1 :*

‎Data/Aeson/Types/Internal.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -45,6 +45,7 @@ module Data.Aeson.Types.Internal
4545
, parseEither
4646
, parseMaybe
4747
, modifyFailure
48+
, prependFailure
4849
, parserThrowError
4950
, parserCatchError
5051
, formatError
@@ -513,6 +514,15 @@ modifyFailure :: (String -> String) -> Parser a -> Parser a
513514
modifyFailure f (Parser p) = Parser $ \path kf ks ->
514515
p path (\p' m -> kf p' (f m)) ks
515516

517+
-- | If the inner 'Parser' failed, prepend the given string to the failure
518+
-- message.
519+
--
520+
-- @
521+
-- 'prependFailure' s = 'modifyFailure' (s '++')
522+
-- @
523+
prependFailure :: String -> Parser a -> Parser a
524+
prependFailure = modifyFailure . (++)
525+
516526
-- | Throw a parser error with an additional path.
517527
--
518528
-- @since 1.2.1.0

‎aeson.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,7 @@ extra-source-files:
4242
include/*.h
4343
tests/JSONTestSuite/test_parsing/*.json
4444
tests/JSONTestSuite/test_transform/*.json
45+
tests/golden/*.expected
4546
pure/Data/Aeson/Parser/*.hs
4647

4748
flag developer
@@ -221,6 +222,7 @@ test-suite tests
221222
containers,
222223
directory,
223224
dlist,
225+
Diff,
224226
filepath,
225227
generic-deriving >= 1.10 && < 1.13,
226228
ghc-prim >= 0.2,
@@ -229,6 +231,7 @@ test-suite tests
229231
tagged,
230232
template-haskell,
231233
tasty,
234+
tasty-golden,
232235
tasty-hunit,
233236
tasty-quickcheck,
234237
text,

‎tests/Encoders.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -414,3 +414,13 @@ gOneConstructorToEncodingTagged = genericToEncoding optsTagSingleConstructors
414414

415415
gOneConstructorParseJSONTagged :: Value -> Parser OneConstructor
416416
gOneConstructorParseJSONTagged = genericParseJSON optsTagSingleConstructors
417+
418+
--------------------------------------------------------------------------------
419+
-- Product2 encoders/decoders
420+
--------------------------------------------------------------------------------
421+
422+
thProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)
423+
thProduct2ParseJSON = $(mkParseJSON defaultOptions ''Product2)
424+
425+
gProduct2ParseJSON :: Value -> Parser (Product2 Int Bool)
426+
gProduct2ParseJSON = genericParseJSON defaultOptions

‎tests/ErrorMessages.hs‎

Lines changed: 174 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -9,62 +9,185 @@ module ErrorMessages
99

1010
import Prelude.Compat
1111

12-
import Data.Aeson (FromJSON(..), eitherDecode)
12+
import Data.Aeson (FromJSON(..), Value, json)
13+
import Data.Aeson.Types (Parser)
14+
import Data.Aeson.Parser (eitherDecodeWith)
15+
import Data.Aeson.Internal (formatError, iparse)
16+
import Data.Algorithm.Diff (Diff(..), getGroupedDiff)
1317
import Data.Proxy (Proxy(..))
18+
import Data.Semigroup ((<>))
19+
import Data.Sequence (Seq)
1420
import Instances ()
1521
import Numeric.Natural (Natural)
16-
import Test.Tasty (TestTree)
17-
import Test.Tasty.HUnit (Assertion, assertFailure, assertEqual, testCase)
22+
import Test.Tasty (TestTree, TestName)
23+
import Test.Tasty.Golden.Advanced (goldenTest)
1824
import qualified Data.ByteString.Lazy.Char8 as L
1925
import qualified Data.HashMap.Strict as HM
2026

27+
import Encoders
28+
import Types
29+
2130
tests :: [TestTree]
2231
tests =
23-
[
24-
testCase "Int" int
25-
, testCase "Integer" integer
26-
, testCase "Natural" natural
27-
, testCase "String" string
28-
, testCase "HashMap" hashMap
29-
]
30-
31-
int :: Assertion
32-
int = do
33-
let t = test (Proxy :: Proxy Int)
34-
t "\"\"" $ expected "Int" "String"
35-
t "[]" $ expected "Int" "Array"
36-
t "{}" $ expected "Int" "Object"
37-
t "null" $ expected "Int" "Null"
38-
39-
integer :: Assertion
40-
integer = do
41-
let t = test (Proxy :: Proxy Integer)
42-
t "44.44" $ expected "Integer" "floating number 44.44"
43-
44-
natural :: Assertion
45-
natural = do
46-
let t = test (Proxy :: Proxy Natural)
47-
t "44.44" $ expected "Natural" "floating number 44.44"
48-
t "-50" $ expected "Natural" "negative number -50"
49-
50-
string :: Assertion
51-
string = do
52-
let t = test (Proxy :: Proxy String)
53-
t "1" $ expected "String" "Number"
54-
t "[]" $ expected "String" "Array"
55-
t "{}" $ expected "String" "Object"
56-
t "null" $ expected "String" "Null"
57-
58-
hashMap :: Assertion
59-
hashMap = do
60-
let t = test (Proxy :: Proxy (HM.HashMap String Int))
61-
t "\"\"" $ expected "HashMap k v" "String"
62-
t "[]" $ expected "HashMap k v" "Array"
63-
64-
expected :: String -> String -> String
65-
expected ex enc = "Error in $: expected " ++ ex ++ ", encountered " ++ enc
66-
67-
test :: forall a proxy . (FromJSON a, Show a) => proxy a -> L.ByteString -> String -> Assertion
68-
test _ v msg = case eitherDecode v of
69-
Left e -> assertEqual "Invalid error message" msg e
70-
Right (x :: a) -> assertFailure $ "Expected parsing to fail but it suceeded with: " ++ show x
32+
[ aesonGoldenTest "simple" "tests/golden/simple.expected" output
33+
, aesonGoldenTest "generic" "tests/golden/generic.expected" (outputGeneric G)
34+
]
35+
36+
output :: Output
37+
output = concat
38+
[ testFor "Int" (Proxy :: Proxy Int)
39+
[ "\"\""
40+
, "[]"
41+
, "{}"
42+
, "null"
43+
]
44+
45+
, testFor "Integer" (Proxy :: Proxy Integer)
46+
[ "44.44"
47+
]
48+
49+
, testFor "Natural" (Proxy :: Proxy Natural)
50+
[ "44.44"
51+
, "-50"
52+
]
53+
54+
, testFor "String" (Proxy :: Proxy String)
55+
[ "1"
56+
, "[]"
57+
, "{}"
58+
, "null"
59+
]
60+
61+
, testFor "HashMap" (Proxy :: Proxy (HM.HashMap String Int))
62+
[ "\"\""
63+
, "[]"
64+
]
65+
66+
-- issue #356
67+
, testFor "Either" (Proxy :: Proxy (Int, Either (Int, Bool) ()))
68+
[ "[1,{\"Left\":[2,3]}]"
69+
]
70+
71+
-- issue #358
72+
, testFor "Seq" (Proxy :: Proxy (Seq Int))
73+
[ "[0,1,true]"
74+
]
75+
]
76+
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+
]
121+
122+
, testWithSomeType "SomeType (two-element array)"
123+
(select
124+
thSomeTypeParseJSON2ElemArray
125+
gSomeTypeParseJSON2ElemArray)
126+
[ "[\"unary\", true]"
127+
, "[\"record\", null]"
128+
, "[\"X\", 0]"
129+
, "[null, 0]"
130+
, "[]"
131+
, "{}"
132+
]
133+
134+
, testWith "EitherTextInt"
135+
(select
136+
thEitherTextIntParseJSONUntaggedValue
137+
gEitherTextIntParseJSONUntaggedValue)
138+
[ "\"X\""
139+
, "[]"
140+
]
141+
142+
, testWith "Product2 Int Bool"
143+
(select
144+
thProduct2ParseJSON
145+
gProduct2ParseJSON)
146+
[ "[1, null]"
147+
, "[]"
148+
, "{}"
149+
]
150+
]
151+
where
152+
select a b = case choice of
153+
TH -> a
154+
G -> b
155+
156+
-- Test infrastructure
157+
158+
type Output = [String]
159+
160+
outputLine :: String -> Output
161+
outputLine = pure
162+
163+
aesonGoldenTest :: TestName -> FilePath -> Output -> TestTree
164+
aesonGoldenTest name ref out = goldenTest name (L.readFile ref) act cmp upd
165+
where
166+
act = pure (L.pack (unlines out))
167+
upd = L.writeFile ref
168+
cmp x y | x == y = return Nothing
169+
cmp x y = return $ Just $ unlines $
170+
concatMap f (getGroupedDiff (L.lines x) (L.lines y))
171+
where
172+
f (First xs) = map (cons3 '-' . L.unpack) xs
173+
f (Second ys) = map (cons3 '+' . L.unpack) ys
174+
-- we print unchanged lines too. It shouldn't be a problem while we have
175+
-- reasonably small examples
176+
f (Both xs _) = map (cons3 ' ' . L.unpack) xs
177+
-- we add three characters, so the changed lines are easier to spot
178+
cons3 c cs = c : c : c : ' ' : cs
179+
180+
testWith :: Show a => String -> (Value -> Parser a) -> [L.ByteString] -> Output
181+
testWith name parser ts =
182+
outputLine name <>
183+
foldMap (\s ->
184+
case eitherDecodeWith json (iparse parser) s of
185+
Left err -> outputLine $ uncurry formatError err
186+
Right a -> outputLine $ show a) ts
187+
188+
testFor :: forall a proxy. (FromJSON a, Show a)
189+
=> String -> proxy a -> [L.ByteString] -> Output
190+
testFor name _ = testWith name (parseJSON :: Value -> Parser a)
191+
192+
testWithSomeType :: String -> (Value -> Parser (SomeType Int)) -> [L.ByteString] -> Output
193+
testWithSomeType = testWith

0 commit comments

Comments
 (0)