Compare revisions

Oleg Grenrus · Oleg Grenrus · Oleg Grenrus · Oleg Grenrus · Oleg Grenrus · Oleg Grenrus
--- a/.github/workflows/haskell-ci.yml
+++ b/.github/workflows/haskell-ci.yml
@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.17.20230826
+# version: 0.19.20240402
 #
-# REGENDATA ("0.17.20230826",["github","cabal.project"])
+# REGENDATA ("0.19.20240402",["github","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -32,19 +32,24 @@ jobs:
    strategy:
      matrix:
        include:
-          - compiler: ghc-9.8.0.20230822
+          - compiler: ghc-9.10.0.20240328
            compilerKind: ghc
-            compilerVersion: 9.8.0.20230822
+            compilerVersion: 9.10.0.20240328
            setup-method: ghcup
-            allow-failure: true
-          - compiler: ghc-9.6.2
+            allow-failure: false
+          - compiler: ghc-9.8.2
+            compilerKind: ghc
+            compilerVersion: 9.8.2
+            setup-method: ghcup
+            allow-failure: false
+          - compiler: ghc-9.6.4
            compilerKind: ghc
-            compilerVersion: 9.6.2
+            compilerVersion: 9.6.4
            setup-method: ghcup
            allow-failure: false
-          - compiler: ghc-9.4.7
+          - compiler: ghc-9.4.8
            compilerKind: ghc
-            compilerVersion: 9.4.7
+            compilerVersion: 9.4.8
            setup-method: ghcup
            allow-failure: false
          - compiler: ghc-9.2.8
@@ -115,20 +120,20 @@ jobs:
          apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5
          if [ "${{ matrix.setup-method }}" = ghcup ]; then
            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml;
+            "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml;
            "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false)
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
          else
            apt-add-repository -y 'ppa:hvr/ghc'
            apt-get update
            apt-get install -y "$HCNAME"
            mkdir -p "$HOME/.ghcup/bin"
-            curl -sL https://downloads.haskell.org/ghcup/0.1.19.5/x86_64-linux-ghcup-0.1.19.5 > "$HOME/.ghcup/bin/ghcup"
+            curl -sL https://downloads.haskell.org/ghcup/0.1.20.0/x86_64-linux-ghcup-0.1.20.0 > "$HOME/.ghcup/bin/ghcup"
            chmod a+x "$HOME/.ghcup/bin/ghcup"
-            "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.7.yaml;
-            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
+            "$HOME/.ghcup/bin/ghcup" config add-release-channel https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-prereleases-0.0.8.yaml;
+            "$HOME/.ghcup/bin/ghcup" install cabal 3.10.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false)
          fi
        env:
          HCKIND: ${{ matrix.compilerKind }}
@@ -148,20 +153,20 @@ jobs:
            echo "HC=$HC" >> "$GITHUB_ENV"
            echo "HCPKG=$HCPKG" >> "$GITHUB_ENV"
            echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
          else
            HC=$HCDIR/bin/$HCKIND
            echo "HC=$HC" >> "$GITHUB_ENV"
            echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV"
            echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV"
-            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV"
+            echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.2.0 -vnormal+nowrap" >> "$GITHUB_ENV"
          fi

          HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')
          echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV"
          echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV"
          echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV"
-          if [ $((HCNUMVER >= 90800)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
+          if [ $((HCNUMVER >= 91000)) -ne 0 ] ; then echo "HEADHACKAGE=true" >> "$GITHUB_ENV" ; else echo "HEADHACKAGE=false" >> "$GITHUB_ENV" ; fi
          echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV"
          echo "GHCJSARITH=0" >> "$GITHUB_ENV"
        env:

--- a/ChangeLog.md
+++ b/ChangeLog.md
+### 3.1.17.0
+
+- Move `many1 :: ParsecT s u m a -> ParsecT s u m [a]` to `Text.Parsec.Prim`.
+  Drop `Stream` constraint requirement.
+- 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.
+- Add `Exception ParseError` instance
+
 ### 3.1.16.0

 - Add `tokens'` and `string'` combinators which don't consume the prefix.

--- a/parsec.cabal
+++ b/parsec.cabal
 cabal-version:  1.12
 name:           parsec
-version:        3.1.16.1
+version:        3.1.17.0
+x-revision:     1

 synopsis:       Monadic parser combinators
 description:    Parsec is designed from scratch as an industrial-strength parser
@@ -26,7 +27,7 @@ bug-reports:    https://github.com/haskell/parsec/issues
 category:       Parsing

 build-type:     Simple
-tested-with:    GHC ==9.8.1 || ==9.6.2 || ==9.4.7 || ==9.2.8 || ==9.0.2 || ==8.10.7 || ==8.8.4 || ==8.6.5 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2
+tested-with:    GHC ==9.10.1 || ==9.8.2 || ==9.6.4 || ==9.4.8 || ==9.2.8 || ==9.0.2 || ==8.10.7 || ==8.8.4 || ==8.6.5 || ==8.4.4 || ==8.2.2 || ==8.0.2 || ==7.10.3 || ==7.8.4 || ==7.6.3 || ==7.4.2

 extra-source-files: ChangeLog.md, README.md

@@ -64,7 +65,7 @@ library
        Text.ParserCombinators.Parsec.Token

    build-depends:
-        base       >= 4.5.1.0 && < 4.20,
+        base       >= 4.5.1.0 && < 4.21,
        mtl        >= 2.1.3.1 && < 2.4,
        bytestring >= 0.9.2.1 && < 0.13,
        text      (>= 1.2.3.0  && < 1.3)
@@ -124,7 +125,7 @@ test-suite parsec-tests
        mtl,
        parsec,
        -- dependencies whose version bounds are not inherited via lib:parsec
-        tasty >= 1.4 && < 1.5,
+        tasty >= 1.4 && < 1.6,
        tasty-hunit >= 0.10 && < 0.11

    default-language: Haskell2010
@@ -141,3 +142,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
--- a/src/Text/Parsec/Combinator.hs
+++ b/src/Text/Parsec/Combinator.hs
@@ -106,24 +106,6 @@ skipMany p          = scan
                      scan  = do{ p; scan } <|> return ()
 -}

-- | @many1 p@ applies the parser @p@ /one/ or more times. Returns a
-- list of the returned values of @p@.
--
-- >  word  = many1 letter
-
-many1 :: (Stream s m t) => ParsecT s u m a -> ParsecT s u m [a]
-{-# INLINABLE many1 #-}
-many1 p             = do{ x <- p; xs <- many p; return (x:xs) }
-{-
-many p              = scan id
-                    where
-                      scan f    = do{ x <- p
-                                    ; scan (\tail -> f (x:tail))
-                                    }
-                                <|> return (f [])
-}
-
-
 -- | @sepBy p sep@ parses /zero/ or more occurrences of @p@, separated
 -- by @sep@. Returns a list of values returned by @p@.
 --

--- a/src/Text/Parsec/Error.hs
+++ b/src/Text/Parsec/Error.hs
@@ -25,8 +25,10 @@ module Text.Parsec.Error
    , mergeError
    ) where

+import Control.Exception ( Exception )
 import Data.List ( nub, sort )
 import Data.Typeable ( Typeable )
+import qualified Data.Monoid as Mon

 import Text.Parsec.Pos

@@ -145,12 +147,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 = Mon.mappend (compare (sourceLine x) (sourceLine y)) (compare (sourceColumn x) (sourceColumn y))
+
 instance Show ParseError where
    show err
        = show (errorPos err) ++ ":" ++
@@ -164,6 +171,9 @@ instance Eq ParseError where
        where
          messageStrs = map messageString . errorMessages

+-- | @since 3.1.17.0
+instance Exception ParseError
+
 -- Language independent show function

 --  TODO

--- a/src/Text/Parsec/Prim.hs
+++ b/src/Text/Parsec/Prim.hs
@@ -61,6 +61,7 @@ module Text.Parsec.Prim
    , many
    , skipMany
    , manyAccum
+    , many1
    , runPT
    , runP
    , runParserT
@@ -270,6 +271,12 @@ instance Applicative.Alternative (ParsecT s u m) where
    empty = mzero
    (<|>) = mplus

+    -- TODO: https://github.com/haskell/parsec/issues/179
+    -- investigate what's wrong with haddock
+    --
+    -- many = many
+    -- some = many1
+
 instance Monad (ParsecT s u m) where
    return = Applicative.pure
    p >>= f = parserBind p f
@@ -715,6 +722,15 @@ many p
  = do xs <- manyAccum (:) p
       return (reverse xs)

+-- | @many1 p@ applies the parser @p@ /one/ or more times. Returns a
+-- list of the returned values of @p@.
+--
+-- >  word  = many1 letter
+
+many1 :: ParsecT s u m a -> ParsecT s u m [a]
+{-# INLINABLE many1 #-}
+many1 p = do{ x <- p; xs <- many p; return (x:xs) }
+
 -- | @skipMany p@ applies the parser @p@ /zero/ or more times, skipping
 -- its result.
 --

--- a/test/issue127.hs
+++ b/test/issue127.hs
+-- this should run in constant memory
 module Main (main) where
  
 import Text.Parsec

--- a/test/issue171.hs
+++ b/test/issue171.hs
+-- 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 < 200)
+
+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"
--- a/test/issue175.hs
+++ b/test/issue175.hs
+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'
No results found