From 5678ad26f83ef27ee08984a35844a8cc1dc7fc2f Mon Sep 17 00:00:00 2001
From: Chris Martin <ch.martin@gmail.com>
Date: Fri, 18 Mar 2022 14:49:05 -0600
Subject: [PATCH] Improve message produced by eitherResult for Partial

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"
---
 Data/Attoparsec/ByteString.hs | 9 +++++----
 Data/Attoparsec/Text.hs       | 9 +++++----
 tests/QC/ByteString.hs        | 8 ++++++++
 tests/QC/Text.hs              | 8 ++++++++
 4 files changed, 26 insertions(+), 8 deletions(-)

diff --git a/Data/Attoparsec/ByteString.hs b/Data/Attoparsec/ByteString.hs
index 0de9bc04..f8b26521 100644
--- a/Data/Attoparsec/ByteString.hs
+++ b/Data/Attoparsec/ByteString.hs
@@ -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"
diff --git a/Data/Attoparsec/Text.hs b/Data/Attoparsec/Text.hs
index bb8ef290..e020f372 100644
--- a/Data/Attoparsec/Text.hs
+++ b/Data/Attoparsec/Text.hs
@@ -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.
diff --git a/tests/QC/ByteString.hs b/tests/QC/ByteString.hs
index dbf29740..f9e6d126 100644
--- a/tests/QC/ByteString.hs
+++ b/tests/QC/ByteString.hs
@@ -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
@@ -211,4 +218,5 @@ tests = [
     , testProperty "word8" word8
     , testProperty "members" members
     , testProperty "nonmembers" nonmembers
+    , testProperty "eitherResultPartialError" eitherResultPartialError
   ]
diff --git a/tests/QC/Text.hs b/tests/QC/Text.hs
index 079dd6fb..872a5667 100644
--- a/tests/QC/Text.hs
+++ b/tests/QC/Text.hs
@@ -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
@@ -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
   ]