Skip to content

Commit

Permalink
Improve message produced by eitherResult for Partial
Browse files Browse the repository at this point in the history
When a parser result is Partial, previously the eitherResult function
showed a generic error message that includes no useful information other
than a generic "incomplete input" message.

For example, if we let

    p = (,) <$> letter <*> digit <?> "thing"

then

    eitherResult (parse p "a") = Left "Result: incomplete input"

Attoparsec is already capable of generating more informative error
information for this example, as we can demonstrate by using parseOnly:

    parseOnly p "a" = "thing > digit: not enough input"

This change brings that same error message to eitherResult by simply
feeding `mempty` into the continuation. With this change, eitherResult
now gives the same output as parseOnly.

    eitherResult (parse p "a") = "thing > digit: not enough input"
  • Loading branch information
chris-martin committed May 5, 2022
1 parent 71a67cb commit 5678ad2
Show file tree
Hide file tree
Showing 4 changed files with 26 additions and 8 deletions.
9 changes: 5 additions & 4 deletions Data/Attoparsec/ByteString.hs
Original file line number Diff line number Diff line change
Expand Up @@ -226,7 +226,8 @@ maybeResult _ = Nothing
-- | Convert a 'Result' value to an 'Either' value. A 'T.Partial'
-- result is treated as failure.
eitherResult :: Result r -> Either String r
eitherResult (T.Done _ r) = Right r
eitherResult (T.Fail _ [] msg) = Left msg
eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)
eitherResult _ = Left "Result: incomplete input"
eitherResult result = case feed result B.empty of
T.Done _ r -> Right r
T.Fail _ [] msg -> Left msg
T.Fail _ ctxs msg -> Left (intercalate " > " ctxs ++ ": " ++ msg)
T.Partial _ -> error "eitherResult: Partial"
9 changes: 5 additions & 4 deletions Data/Attoparsec/Text.hs
Original file line number Diff line number Diff line change
Expand Up @@ -266,10 +266,11 @@ maybeResult _ = Nothing
-- | Convert a 'Result' value to an 'Either' value. A 'Partial' result
-- is treated as failure.
eitherResult :: Result r -> Either String r
eitherResult (T.Done _ r) = Right r
eitherResult (T.Fail _ [] msg) = Left msg
eitherResult (T.Fail _ ctxs msg) = Left (intercalate " > " ctxs ++ ": " ++ msg)
eitherResult _ = Left "Result: incomplete input"
eitherResult result = case feed result T.empty of
T.Done _ r -> Right r
T.Fail _ [] msg -> Left msg
T.Fail _ ctxs msg -> Left (intercalate " > " ctxs ++ ": " ++ msg)
T.Partial _ -> error "eitherResult: Partial"

-- | A predicate that matches either a carriage return @\'\\r\'@ or
-- newline @\'\\n\'@ character.
Expand Down
8 changes: 8 additions & 0 deletions tests/QC/ByteString.hs
Original file line number Diff line number Diff line change
Expand Up @@ -182,6 +182,13 @@ nonmembers :: [Word8] -> [Word8] -> Property
nonmembers s s' = property . not . any (`S.memberWord8` set) $ filter (not . (`elem` s)) s'
where set = S.fromList s

eitherResultPartialError :: Property
eitherResultPartialError = P.eitherResult (P.parse p input) === Left msg
where
p = (,) <$> P8.letter_ascii <*> P8.digit P.<?> "thing"
input = "a"
msg = "thing > digit: not enough input"

tests :: [TestTree]
tests = [
testProperty "anyWord8" anyWord8
Expand Down Expand Up @@ -211,4 +218,5 @@ tests = [
, testProperty "word8" word8
, testProperty "members" members
, testProperty "nonmembers" nonmembers
, testProperty "eitherResultPartialError" eitherResultPartialError
]
8 changes: 8 additions & 0 deletions tests/QC/Text.hs
Original file line number Diff line number Diff line change
Expand Up @@ -170,6 +170,13 @@ nonmembers :: String -> String -> Property
nonmembers s s' = property . not . any (`S.member` set) $ filter (not . (`elem` s)) s'
where set = S.fromList s

eitherResultPartialError :: Property
eitherResultPartialError = P.eitherResult (P.parse p input) === Left msg
where
input = "a"
p = (,) <$> P.letter <*> P.digit P.<?> "thing"
msg = "thing > digit: not enough input"

tests :: [TestTree]
tests = [
testProperty "anyChar" anyChar
Expand Down Expand Up @@ -198,6 +205,7 @@ tests = [
, testProperty "takeWhile1_empty" takeWhile1_empty
, testProperty "members" members
, testProperty "nonmembers" nonmembers
, testProperty "eitherResultPartialError" eitherResultPartialError
, testGroup "FastSet" FastSet.tests
, testGroup "Regressions" Regressions.tests
]

0 comments on commit 5678ad2

Please sign in to comment.