Resolve #171.

Don't compare source names when deciding "longer match"
in mergeError. #175 would be a better fix, but that would require
a major bump.

Author: phadej

ChangeLog.md

@@ -4,6 +4,9 @@
   Drop `Stream` constraint requirement.
 - Implement `Alternative.many/some` using `Text.Parsec.Prim.many/many1`,
   instead of default implementation.
+- Change the position comparison in `mergeError` to not compare source names.
+  This doesn't alter reported error positions when only a single source is parsed.
+  This fixes performance issue caused by long source names.
 
 ### 3.1.16.0
 

parsec.cabal

@@ -141,3 +141,17 @@ test-suite parsec-issue127
     main-is: issue127.hs
     hs-source-dirs: test
     build-depends: base, parsec
+
+test-suite parsec-issue171
+    default-language: Haskell2010
+    type: exitcode-stdio-1.0
+    main-is: issue171.hs
+    hs-source-dirs: test
+    build-depends: base, tasty, tasty-hunit, deepseq, parsec
+
+test-suite parsec-issue175
+    default-language: Haskell2010
+    type: exitcode-stdio-1.0
+    main-is: issue175.hs
+    hs-source-dirs: test
+    build-depends: base, tasty, tasty-hunit, parsec

src/Text/Parsec/Error.hs

@@ -145,12 +145,17 @@ mergeError e1@(ParseError pos1 msgs1) e2@(ParseError pos2 msgs2)
     | null msgs2 && not (null msgs1) = e1
     | null msgs1 && not (null msgs2) = e2
     | otherwise
-    = case pos1 `compare` pos2 of
+      -- perfectly we'd compare the consumed token count
+      -- https://github.com/haskell/parsec/issues/175
+    = case compareErrorPos pos1 pos2 of
         -- select the longest match
         EQ -> ParseError pos1 (msgs1 ++ msgs2)
         GT -> e1
         LT -> e2
 
+compareErrorPos :: SourcePos -> SourcePos -> Ordering
+compareErrorPos x y = mappend (compare (sourceLine x) (sourceLine y)) (compare (sourceColumn x) (sourceColumn y))
+
 instance Show ParseError where
     show err
         = show (errorPos err) ++ ":" ++

test/issue127.hs

@@ -1,3 +1,4 @@
+-- this should run in constant memory
 module Main (main) where
 
 import Text.Parsec

test/issue171.hs

@@ -0,0 +1,29 @@
+-- this should be fast
+module Main (main) where
+
+import Control.DeepSeq (NFData (..))
+import System.CPUTime (getCPUTime)
+import Text.Printf (printf)
+import Test.Tasty (defaultMain)
+import Test.Tasty.HUnit (testCaseSteps, assertBool)
+
+import Text.Parsec
+import Text.Parsec.String (Parser)
+
+main :: IO ()
+main = defaultMain $ testCaseSteps "issue-171" $ \info -> do
+  time0 <- getCPUTime
+  check $ concat $ replicate 100000 "a "
+  time1 <- getCPUTime
+  let diff = (time1 - time0) `div` 1000000000
+  info $ printf "%d milliseconds\n" diff
+  assertBool "" (diff < 100)
+
+parser :: Parser [String]
+parser = many (char 'a' <|> char 'b') `sepBy` char ' '
+
+check :: String -> IO ()
+check s = putStrLn $ either onError (const "") $ parse parser {- important: pass input as SourceName -} s s
+
+onError :: ParseError -> String
+onError err = rnf (show err) `seq` "error"

test/issue175.hs

@@ -0,0 +1,26 @@
+module Main (main) where
+
+import Text.Parsec
+import Text.Parsec.Error
+import Text.Parsec.String (Parser)
+import Text.Parsec.Pos (newPos)
+
+import Test.Tasty (defaultMain)
+import Test.Tasty.HUnit (assertFailure, testCaseSteps, (@?=))
+
+main :: IO ()
+main = defaultMain $ testCaseSteps "issue175" $ \info -> do
+    case parse p "" "x" of
+        Right _ -> assertFailure "Unexpected success"
+        -- with setPosition the "longest match" is arbitrary
+        -- megaparsec tracks consumed tokens separately, but we don't.
+        -- so our position is arbitrary.
+        Left err -> do
+            info $ show err
+            errorPos err @?= newPos "aaa" 9 1  -- can be arbitrary
+            length (errorMessages err) @?= 2
+
+p :: Parser Char
+p = p1 <|> p2 where
+    p1 = setPosition (newPos "aaa" 9 1) >> char 'a'
+    p2 = setPosition (newPos "zzz" 1 1) >> char 'b'