Merge pull request #695 from FintanH/fintan/better-errors

Add labels to json object and list parsing

Author: bergmark

Data/Aeson/Parser/Internal.hs

@@ -123,9 +123,9 @@ objectValues str val = do
   -- Why use acc pattern here, you may ask? because 'H.fromList' use 'unsafeInsert'
   -- and it's much faster because it's doing in place update to the 'HashMap'!
   loop acc = do
-    k <- str <* skipSpace <* char ':'
-    v <- val <* skipSpace
-    ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_CURLY
+    k <- (str A.<?> "object key") <* skipSpace <* (char ':' A.<?> "':'")
+    v <- (val A.<?> "object value") <* skipSpace
+    ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_CURLY) A.<?> "',' or '}'"
     let acc' = (k, v) : acc
     if ch == COMMA
       then skipSpace >> loop acc'
@@ -149,8 +149,8 @@ arrayValues val = do
     else loop [] 1
   where
     loop acc !len = do
-      v <- val <* skipSpace
-      ch <- A.satisfy $ \w -> w == COMMA || w == CLOSE_SQUARE
+      v <- (val A.<?> "json list value") <* skipSpace
+      ch <- A.satisfy (\w -> w == COMMA || w == CLOSE_SQUARE) A.<?> "',' or ']'"
       if ch == COMMA
         then skipSpace >> loop (v:acc) (len+1)
         else return (Vector.reverse (Vector.fromListN len (v:acc)))
@@ -275,7 +275,12 @@ eitherDecodeWith p to s =
       L.Done _ v     -> case to v of
                           ISuccess a      -> Right a
                           IError path msg -> Left (path, msg)
-      L.Fail _ _ msg -> Left ([], msg)
+      L.Fail _ ctx msg -> Left ([], buildMsg ctx msg)
+  where
+    buildMsg :: [String] -> String -> String
+    buildMsg [] msg = msg
+    buildMsg (expectation:_) msg =
+      msg ++ ". Expecting " ++ expectation
 {-# INLINE eitherDecodeWith #-}
 
 eitherDecodeStrictWith :: Parser Value -> (Value -> IResult a) -> B.ByteString

tests/ErrorMessages.hs

@@ -117,6 +117,9 @@ outputGeneric choice = concat
       , "{\"record\": {}, \"W\":{}}"
       , "{}"
       , "[]"
+      , "{\"unary\""
+      , "{\"unary\":"
+      , "{\"unary\":1"
       ]
 
   , testWithSomeType "SomeType (two-element array)"
@@ -129,6 +132,8 @@ outputGeneric choice = concat
       , "[null, 0]"
       , "[]"
       , "{}"
+      , "[1"
+      , "[1,"
       ]
 
   , testWith "EitherTextInt"

tests/golden/generic.expected

@@ -19,13 +19,18 @@ Error in $: parsing Types.SomeType failed, expected an Object with a single pair
 Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 2 pairs
 Error in $: parsing Types.SomeType failed, expected an Object with a single pair, but found 0 pairs
 Error in $: parsing Types.SomeType failed, expected Object, but encountered Array
+Error in $: not enough input. Expecting ':'
+Error in $: not enough input. Expecting object value
+Error in $: not enough input. Expecting ',' or '}'
 SomeType (two-element array)
 Error in $[1]: parsing Int failed, expected Number, but encountered Boolean
 Error in $[1]: parsing Types.SomeType(Record) failed, expected Object, but encountered Null
 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"
 Error in $[0]: parsing Types.SomeType failed, tag element is not a String
 Error in $: parsing Types.SomeType failed, expected a 2-element Array, but encountered an Array of length 0
 Error in $: parsing Types.SomeType failed, expected Array, but encountered Object
+Error in $: not enough input. Expecting ',' or ']'
+Error in $: not enough input. Expecting json list value
 EitherTextInt
 Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected tag "nonenullary", but found tag "X"
 Error in $: parsing Types.EitherTextInt(NoneNullary) failed, expected String, but encountered Array