content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE Rank2Types #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE RecursiveDo #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Text.MegaparsecSpec (spec) where
  
  import Control.Monad (ap, forM_, guard, unless, void, when)
  import Control.Monad.Cont (Cont, callCC, runCont)
  import Control.Monad.Except (catchError, throwError)
  import Control.Monad.Fix (MonadFix)
  import Control.Monad.IO.Class (liftIO)
  import Control.Monad.Identity (runIdentity)
  import qualified Control.Monad.RWS.Lazy as L
  import qualified Control.Monad.RWS.Strict as S
  import Control.Monad.Reader (Reader, ask, asks, local, runReader, runReaderT)
  import qualified Control.Monad.State.Lazy as L
  import qualified Control.Monad.State.Strict as S
  import Control.Monad.Trans.Except (Except, runExcept)
  import qualified Control.Monad.Writer.Lazy as L
  import qualified Control.Monad.Writer.Strict as S
  import qualified Data.ByteString as BS
  import Data.Char (isLetter, toUpper)
  import Data.Foldable (asum)
  import Data.List (isPrefixOf)
  import qualified Data.List as DL
  import qualified Data.List.NonEmpty as NE
  import Data.Semigroup
  import qualified Data.Set as E
  import Data.String
  import qualified Data.Text as T
  import Data.Void
  import Test.Hspec
  import Test.Hspec.Megaparsec
  import Test.Hspec.Megaparsec.AdHoc
  import Test.QuickCheck hiding (label)
  import Text.Megaparsec
  import Text.Megaparsec.Char
  import qualified Text.Megaparsec.Internal as Internal
  import Prelude hiding (concat, span)
  
  spec :: Spec
  spec = do
    describe "ParsecT Semigroup instance" $
      it "the associative operation works" $
        property $ \a b -> do
          let p = pure [a] <> pure [b]
          prs p "" `shouldParse` ([a, b] :: [Int])
  
    describe "ParsecT Monoid instance" $ do
      it "mempty works" $ do
        let p = mempty
        prs p "" `shouldParse` ([] :: [Int])
      it "mappend works" $
        property $ \a b -> do
          let p = pure [a] `mappend` pure [b]
          prs p "" `shouldParse` ([a, b] :: [Int])
  
    describe "ParsecT IsString instance" $ do
      describe "equivalence to 'string'" $ do
        it "for String" $
          property $ \s i ->
            eqParser
              (chunk s)
              (fromString s)
              (i :: String)
        it "for Text" $
          property $ \s i ->
            eqParser
              (chunk (T.pack s))
              (fromString s)
              (i :: T.Text)
        it "for ByteString" $
          property $ \s i ->
            eqParser
              (chunk (fromString s :: BS.ByteString))
              (fromString s)
              (i :: BS.ByteString)
      it "can handle Unicode" $ do
        let r = "פּאַרסער 解析器" :: BS.ByteString
            p :: Parsec Void BS.ByteString BS.ByteString
            p = BS.concat <$> sequence ["פּאַ", "רסער", " 解析器"]
        parse p "" r `shouldParse` r
  
    describe "ParsecT Functor instance" $ do
      it "obeys identity law" $
        property $ \n ->
          prs (fmap id (pure (n :: Int))) ""
            === prs (id (pure n)) ""
      it "obeys composition law" $
        property $ \n m t ->
          let f = (+ m)
              g = (* t)
           in prs (fmap (f . g) (pure (n :: Int))) ""
                === prs ((fmap f . fmap g) (pure n)) ""
  
    describe "ParsecT Applicative instance" $ do
      it "obeys identity law" $
        property $ \n ->
          prs (pure id <*> pure (n :: Int)) ""
            === prs (pure n) ""
      it "obeys composition law" $
        property $ \n m t ->
          let u = pure (+ m)
              v = pure (* t)
              w = pure (n :: Int)
           in prs (pure (.) <*> u <*> v <*> w) ""
                === prs (u <*> (v <*> w)) ""
      it "obeys homomorphism law" $
        property $ \x m ->
          let f = (+ m)
           in prs (pure f <*> pure (x :: Int)) ""
                === prs (pure (f x)) ""
      it "obeys interchange law" $
        property $ \n y ->
          let u = pure (+ n)
           in prs (u <*> pure (y :: Int)) ""
                === prs (pure ($ y) <*> u) ""
      describe "(<*>)" $
        context "when first parser succeeds without consuming" $
          context "when second parser fails consuming input" $
            it "fails consuming input" $
              do
                let p = m <*> n
                    m = return (\x -> 'a' : x)
                    n = string "bc" <* empty
                    s = "bc"
                prs p s `shouldFailWith` err 2 mempty
                prs' p s `failsLeaving` ""
      describe "(*>)" $
        it "works correctly" $
          property $ \n m ->
            let u = pure (+ (m :: Int))
                v = pure (n :: Int)
             in prs (u *> v) ""
                  === prs (pure (const id) <*> u <*> v) ""
      describe "(<*)" $
        it "works correctly" $
          property $ \n m ->
            let u = pure (m :: Int)
                v = pure (+ (n :: Int))
             in prs (u <* v) "" === prs (pure const <*> u <*> v) ""
  
    describe "ParsecT Alternative instance" $ do
      describe "empty" $
        it "always fails" $
          property $ \n ->
            prs (empty <|> pure n) "" `shouldParse` (n :: Integer)
  
      describe "(<|>)" $ do
        context "with two strings" $ do
          context "stream begins with the first string" $
            it "parses the string" $
              property $ \s0 s1 s ->
                not (s1 `isPrefixOf` s0) ==> do
                  let s' = s0 ++ s
                      p = chunk s0 <|> chunk s1
                  prs p s' `shouldParse` s0
                  prs' p s' `succeedsLeaving` s
          context "stream begins with the second string" $
            it "parses the string" $
              property $ \s0 s1 s ->
                not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do
                  let s' = s1 ++ s
                      p = string s0 <|> string s1
                  prs p s' `shouldParse` s1
                  prs' p s' `succeedsLeaving` s
          context "when stream does not begin with either string" $
            it "signals correct error message" $
              property $ \s0 s1 s ->
                not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do
                  let p = string s0 <|> string s1
                      z = take (max (length s0) (length s1)) s
                  prs p s
                    `shouldFailWith` err
                      0
                      ( etoks s0
                          <> etoks s1
                          <> (if null s then ueof else utoks z)
                      )
        context "with two complex parsers" $ do
          context "when stream begins with matching character" $
            it "parses it" $
              property $ \a b ->
                a /= b ==> do
                  let p = char a <|> (char b *> char a)
                      s = [a]
                  prs p s `shouldParse` a
                  prs' p s `succeedsLeaving` ""
          context "when stream begins with only one matching character" $
            it "signals correct parse error" $
              property $ \a b c ->
                a /= b && a /= c ==> do
                  let p = char a <|> (char b *> char a)
                      s = [b, c]
                  prs p s `shouldFailWith` err 1 (utok c <> etok a)
                  prs' p s `failsLeaving` [c]
          context "when stream begins with not matching character" $
            it "signals correct parse error" $
              property $ \a b c ->
                a /= b && a /= c && b /= c ==> do
                  let p = char a <|> (char b *> char a)
                      s = [c, b]
                  prs p s `shouldFailWith` err 0 (utok c <> etok a <> etok b)
                  prs' p s `failsLeaving` s
          context "when stream is emtpy" $
            it "signals correct parse error" $
              property $ \a b -> do
                let p = char a <|> (char b *> char a)
                prs p "" `shouldFailWith` err 0 (ueof <> etok a <> etok b)
        it "associativity of fold over alternatives should not matter" $ do
          let p = asum [empty, string ">>>", empty, return "foo"] <?> "bar"
              p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"
              bsum = foldl (<|>) empty
              s = ">>"
          prs p s `shouldBe` prs p' s
  
      describe "many" $ do
        context "when stream begins with things argument of many parses" $
          it "they are parsed" $
            property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
              let p = many (char 'a')
                  s = abcRow a b c
              prs p s `shouldParse` replicate a 'a'
              prs' p s `succeedsLeaving` drop a s
        context "when stream does not begin with thing argument of many parses" $
          it "does nothing" $
            property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
              let p = many (char 'd')
                  s = abcRow a b c
              prs p s `shouldParse` ""
              prs' p s `succeedsLeaving` s
        context "when stream is empty" $
          it "succeeds parsing nothing" $
            do
              let p = many (char 'a')
              prs p "" `shouldParse` ""
        context "when there are two many combinators in a row that parse nothing" $
          it "accumulated hints are reflected in parse error" $
            do
              let p = many (char 'a') *> many (char 'b') *> eof
              prs p "c"
                `shouldFailWith` err
                  0
                  (utok 'c' <> etok 'a' <> etok 'b' <> eeof)
        context "when the argument parser succeeds without consuming" $
          it "is run nevertheless" $
            property $ \(NonNegative (Small n)) -> do
              let p = void . many $ do
                    x <- S.get
                    if x < n then S.modify (+ 1) else empty
                  v :: S.State Integer (Either (ParseErrorBundle String Void) ())
                  v = runParserT p "" ("" :: String)
              S.execState v 0 `shouldBe` n
  
      describe "some" $ do
        context "when stream begins with things argument of some parses" $
          it "they are parsed" $
            property $ \(Positive a) (NonNegative b) (NonNegative c) -> do
              let p = some (char 'a')
                  s = abcRow a b c
              prs p s `shouldParse` replicate a 'a'
              prs' p s `succeedsLeaving` drop a s
        context "when stream does not begin with thing argument of some parses" $
          it "signals correct parse error" $
            property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
              let p = some (char 'd')
                  s = abcRow a b c ++ "g"
              prs p s `shouldFailWith` err 0 (utok (head s) <> etok 'd')
              prs' p s `failsLeaving` s
        context "when stream is empty" $
          it "signals correct parse error" $
            property $ \ch -> do
              let p = some (char ch)
              prs p "" `shouldFailWith` err 0 (ueof <> etok ch)
      context "optional" $ do
        context "when stream begins with that optional thing" $
          it "parses it" $
            property $ \a b -> do
              let p = optional (char a) <* char b
                  s = [a, b]
              prs p s `shouldParse` Just a
              prs' p s `succeedsLeaving` ""
        context "when stream does not begin with that optional thing" $
          it "succeeds parsing nothing" $
            property $ \a b ->
              a /= b ==> do
                let p = optional (char a) <* char b
                    s = [b]
                prs p s `shouldParse` Nothing
                prs' p s `succeedsLeaving` ""
        context "when stream is empty" $
          it "succeeds parsing nothing" $
            property $ \a -> do
              let p = optional (char a)
              prs p "" `shouldParse` Nothing
  
    describe "ParsecT Monad instance" $ do
      it "satisfies left identity law" $
        property $ \a k' -> do
          let k = return . (+ k')
              p = return (a :: Int) >>= k
          prs p "" `shouldBe` prs (k a) ""
      it "satisfies right identity law" $
        property $ \a -> do
          let m = return (a :: Int)
              p = m >>= return
          prs p "" `shouldBe` prs m ""
      it "satisfies associativity law" $
        property $ \m' k' h' -> do
          let m = return (m' :: Int)
              k = return . (+ k')
              h = return . (* h')
              p = m >>= (\x -> k x >>= h)
              p' = (m >>= k) >>= h
          prs p "" `shouldBe` prs p' ""
      it "fails signals correct parse error" $
        property $ \msg -> do
          let p = fail msg :: Parsec Void String ()
          prs p "" `shouldFailWith` errFancy 0 (fancy $ ErrorFail msg)
      it "pure is the same as return" $
        property $ \n ->
          prs (pure (n :: Int)) "" `shouldBe` prs (return n) ""
      it "(<*>) is the same as ap" $
        property $ \m' k' -> do
          let m = return (m' :: Int)
              k = return (+ k')
          prs (k <*> m) "" `shouldBe` prs (k `ap` m) ""
  
    describe "ParsecT MonadFail instance" $
      describe "fail" $
        it "signals correct parse error" $
          property $ \s msg -> do
            let p = void (fail msg)
            prs p s `shouldFailWith` errFancy 0 (fancy $ ErrorFail msg)
            prs' p s `failsLeaving` s
  
    describe "ParsecT MonadIO instance" $
      it "liftIO works" $
        property $ \n -> do
          let p = liftIO (return n) :: ParsecT Void String IO Integer
          runParserT p "" "" `shouldReturn` Right n
  
    describe "ParsecT MonadFix instance" $
      it "withRange works" $
        do
          let withRange ::
                ( TraversableStream s,
                  MonadParsec e s m,
                  MonadFix m
                ) =>
                ((SourcePos, SourcePos) -> m a) ->
                m a
              withRange f = do
                p1 <- getSourcePos
                rec r <- f (p1, p2)
                    p2 <- getSourcePos
                return r
              p :: Parsec Void String (SourcePos, SourcePos)
              p = withRange $ \pp -> pp <$ string "ab"
          runParser p "" "abcd"
            `shouldBe` Right
              ( SourcePos "" (mkPos 1) (mkPos 1),
                SourcePos "" (mkPos 1) (mkPos 3)
              )
  
    describe "ParsecT MonadReader instance" $ do
      describe "ask" $ do
        it "returns correct value of context" $
          property $ \n -> do
            let p = ask :: ParsecT Void String (Reader Integer) Integer
            runReader (runParserT p "" "") n `shouldBe` Right n
        it "preserves hints" $
          property $ \a b (n :: Integer) ->
            a /= b ==> do
              let p :: ParsecT Void String (Reader Integer) Integer
                  p = optional (char a) *> ask <* hidden eof
              runReader (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a)
  
      describe "local" $ do
        it "modifies reader context correctly" $
          property $ \n k -> do
            let p = local (+ k) ask :: ParsecT Void String (Reader Integer) Integer
            runReader (runParserT p "" "") n `shouldBe` Right (n + k)
        it "preserves hints" $
          property $ \a b (n :: Integer) ->
            a /= b ==> do
              let p :: ParsecT Void String (Reader Integer) (Maybe Char)
                  p = local (+ 1) (optional (char a)) <* hidden eof
              runReader (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a)
  
    describe "ParsecT MonadState instance" $ do
      describe "get" $ do
        it "returns correct state value" $
          property $ \n -> do
            let p = L.get :: ParsecT Void String (L.State Integer) Integer
            L.evalState (runParserT p "" "") n `shouldBe` Right n
        it "preserves hints" $
          property $ \a b (n :: Integer) ->
            a /= b ==> do
              let p :: ParsecT Void String (L.State Integer) Integer
                  p = optional (char a) *> L.get <* hidden eof
              L.evalState (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a)
  
      describe "put" $ do
        it "replaces state value" $
          property $ \a b -> do
            let p = L.put b :: ParsecT Void String (L.State Integer) ()
            L.execState (runParserT p "" "") a `shouldBe` b
        it "preserves hints" $
          property $ \a b (n :: Integer) (n' :: Integer) ->
            a /= b ==> do
              let p :: ParsecT Void String (L.State Integer) ()
                  p = optional (char a) *> L.put n' <* hidden eof
              L.evalState (runParserT p "" [b]) n `shouldFailWith` err 0 (utok b <> etok a)
  
    describe "ParsecT MonadCont instance" $
      describe "callCC" $
        it "works properly" $
          property $ \a b -> do
            let p :: ParsecT Void String (Cont (Either (ParseErrorBundle String Void) Integer)) Integer
                p = callCC $ \e -> when (a > b) (e a) >> return b
            runCont (runParserT p "" "") id `shouldBe` Right (max a b)
  
    describe "ParsecT MonadError instance" $ do
      describe "throwError" $
        it "throws the error" $
          property $ \a b -> do
            let p :: ParsecT Void String (Except Integer) Integer
                p = throwError a >> return b
            runExcept (runParserT p "" "") `shouldBe` Left a
  
      describe "catchError" $
        it "catches the error" $
          property $ \a b -> do
            let p :: ParsecT Void String (Except Integer) Integer
                p = (throwError a >> return b) `catchError` handler
                handler e = return (e + b)
            runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b)
  
    describe "primitive combinators" $ do
      describe "parseError" $ do
        it "immediately fails with given parse error" $
          property $ \st e -> do
            let p :: (MonadParsec Void String m) => m ()
                p = parseError e
            runParser' p st `shouldBe` (st, Left (mkBundle st (nes e)))
  
      describe "label" $ do
        context "when inner parser succeeds consuming input" $ do
          context "inner parser does not produce any hints" $
            it "collection of hints remains empty" $
              property $ \lbl a ->
                not (null lbl) ==> do
                  let p :: (MonadParsec Void String m) => m Char
                      p = label lbl (char a) <* empty
                      s = [a]
                  grs p s (`shouldFailWith` err 1 mempty)
                  grs' p s (`failsLeaving` "")
          context "inner parser produces hints" $
            it "does not alter the hints" $
              property $ \lbl a ->
                not (null lbl) ==> do
                  let p :: (MonadParsec Void String m) => m String
                      p = label lbl (many (char a)) <* empty
                      s = [a]
                  grs p s (`shouldFailWith` err 1 (etok a))
                  grs' p s (`failsLeaving` "")
        context "when inner parser consumes and fails" $
          it "reports parse error without modification" $
            property $ \lbl a b c ->
              not (null lbl) && b /= c ==> do
                let p :: (MonadParsec Void String m) => m Char
                    p = label lbl (char a *> char b)
                    s = [a, c]
                grs p s (`shouldFailWith` err 1 (utok c <> etok b))
                grs' p s (`failsLeaving` [c])
        context "when inner parser succeeds without consuming" $ do
          context "inner parser does not produce any hints" $
            it "collection of hints remains empty" $
              property $ \lbl a ->
                not (null lbl) ==> do
                  let p :: (MonadParsec Void String m) => m Char
                      p = label lbl (return a) <* empty
                  grs p "" (`shouldFailWith` err 0 mempty)
          context "inner parser produces hints" $
            it "replaces the last hint with given label" $
              property $ \lbl a ->
                not (null lbl) ==> do
                  let p :: (MonadParsec Void String m) => m String
                      p = label lbl (many (char a)) <* empty
                  grs p "" (`shouldFailWith` err 0 (elabel lbl))
        context "when inner parser fails without consuming" $ do
          it "is mentioned in parse error via its label" $
            property $ \lbl ->
              not (null lbl) ==> do
                let p :: (MonadParsec Void String m) => m ()
                    p = label lbl empty
                grs p "" (`shouldFailWith` err 0 (elabel lbl))
          context "when inner parser is composite with 2-hint sources" $
            it "both hint groups are replaced by the label" $
              property $ \lbl a b ->
                not (null lbl) && a /= b ==> do
                  let p :: (MonadParsec Void String m) => m (Maybe Char)
                      p = label lbl (optional (char a) *> optional (char b)) <* empty
                  grs p "" (`shouldFailWith` err 0 (elabel lbl))
      describe "hidden" $ do
        context "when inner parser succeeds consuming input" $ do
          context "inner parser does not produce any hints" $
            it "collection of hints remains empty" $
              property $ \a -> do
                let p :: (MonadParsec Void String m) => m Char
                    p = hidden (char a) <* empty
                    s = [a]
                grs p s (`shouldFailWith` err 1 mempty)
                grs' p s (`failsLeaving` "")
          context "inner parser produces hints" $
            it "hides the parser in the error message" $
              property $ \a -> do
                let p :: (MonadParsec Void String m) => m String
                    p = hidden (many (char a)) <* empty
                    s = [a]
                grs p s (`shouldFailWith` err 1 mempty)
                grs' p s (`failsLeaving` "")
        context "when inner parser consumes and fails" $
          it "reports parse error without modification" $
            property $ \a b c ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m Char
                    p = hidden (char a *> char b)
                    s = [a, c]
                grs p s (`shouldFailWith` err 1 (utok c <> etok b))
                grs' p s (`failsLeaving` [c])
        context "when inner parser succeeds without consuming" $ do
          context "inner parser does not produce any hints" $
            it "collection of hints remains empty" $
              property $ \a -> do
                let p :: (MonadParsec Void String m) => m Char
                    p = hidden (return a) <* empty
                grs p "" (`shouldFailWith` err 0 mempty)
          context "inner parser produces hints" $
            it "hides the parser in the error message" $
              property $ \a -> do
                let p :: (MonadParsec Void String m) => m String
                    p = hidden (many (char a)) <* empty
                grs p "" (`shouldFailWith` err 0 mempty)
        context "when inner parser fails without consuming" $
          it "hides the parser in the error message" $
            do
              let p :: (MonadParsec Void String m) => m ()
                  p = hidden empty
              grs p "" (`shouldFailWith` err 0 mempty)
  
      describe "try" $ do
        context "when inner parser succeeds consuming" $
          it "try has no effect" $
            property $ \a -> do
              let p :: (MonadParsec Void String m) => m Char
                  p = try (char a)
                  s = [a]
              grs p s (`shouldParse` a)
              grs' p s (`succeedsLeaving` "")
        context "when inner parser fails consuming" $ do
          it "backtracks, it appears as if the parser has not consumed anything" $
            property $ \a b c ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m Char
                    p = try (char a *> char b)
                    s = [a, c]
                grs p s (`shouldFailWith` err 1 (utok c <> etok b))
                grs' p s (`failsLeaving` s)
          it "hints from the inner parse error do not leak" $
            property $ \a b c ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m (Maybe Char)
                    p = (optional . try) (char a *> char b) <* empty
                    s = [a, c]
                grs p s (`shouldFailWith` err 0 mempty)
                grs' p s (`failsLeaving` s)
        context "when inner parser succeeds without consuming" $
          it "try has no effect" $
            property $ \a -> do
              let p :: (MonadParsec Void String m) => m Char
                  p = try (return a)
              grs p "" (`shouldParse` a)
        context "when inner parser fails without consuming" $
          it "try backtracks parser state anyway" $
            property $ \w -> do
              let p :: (MonadParsec Void String m) => m Char
                  p = try (setTabWidth w *> empty)
              grs p "" (`shouldFailWith` err 0 mempty)
              grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)
  
      describe "lookAhead" $ do
        context "when inner parser succeeds consuming" $ do
          it "result is returned but parser state is not changed" $
            property $ \a w -> do
              let p :: (MonadParsec Void String m) => m Pos
                  p = lookAhead (setTabWidth w *> char a) *> getTabWidth
                  s = [a]
              grs p s (`shouldParse` defaultTabWidth)
              grs' p s (`succeedsLeaving` s)
          it "hints are not preserved" $
            property $ \a -> do
              let p :: (MonadParsec Void String m) => m String
                  p = lookAhead (many (char a)) <* empty
                  s = [a]
              grs p s (`shouldFailWith` err 0 mempty)
              grs' p s (`failsLeaving` s)
        context "when inner parser fails consuming" $
          it "error message is reported as usual" $
            property $ \a b c ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m Char
                    p = lookAhead (char a *> char b)
                    s = [a, c]
                grs p s (`shouldFailWith` err 1 (utok c <> etok b))
                grs' p s (`failsLeaving` [c])
        context "when inner parser succeeds without consuming" $ do
          it "result is returned but parser state in not changed" $
            property $ \a w -> do
              let p :: (MonadParsec Void String m) => m Pos
                  p = lookAhead (setTabWidth w *> char a) *> getTabWidth
                  s = [a]
              grs p s (`shouldParse` defaultTabWidth)
              grs' p s (`succeedsLeaving` s)
          it "hints are not preserved" $
            property $ \a b ->
              a /= b ==> do
                let p :: (MonadParsec Void String m) => m String
                    p = lookAhead (many (char a)) <* empty
                    s = [b]
                grs p s (`shouldFailWith` err 0 mempty)
                grs' p s (`failsLeaving` s)
        context "when inner parser fails without consuming" $
          it "error message is reported as usual" $
            do
              let p :: (MonadParsec Void String m) => m Char
                  p = lookAhead empty
              grs p "" (`shouldFailWith` err 0 mempty)
  
      describe "notFollowedBy" $ do
        context "when inner parser succeeds consuming" $
          it "signals correct parse error" $
            property $ \a w -> do
              let p :: (MonadParsec Void String m) => m ()
                  p = notFollowedBy (setTabWidth w <* char a)
                  s = [a]
              grs p s (`shouldFailWith` err 0 (utok a))
              grs' p s (`failsLeaving` s)
              grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)
        context "when inner parser fails consuming" $ do
          it "succeeds without consuming" $
            property $ \a b c w ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m ()
                    p = notFollowedBy (setTabWidth w *> char a *> char b)
                    s = [a, c]
                grs' p s (`succeedsLeaving` s)
                grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)
          it "hints are not preserved" $
            property $ \a b ->
              a /= b ==> do
                let p :: (MonadParsec Void String m) => m ()
                    p = notFollowedBy (char b *> many (char a) <* char a) <* empty
                    s = [b, b]
                grs p s (`shouldFailWith` err 0 mempty)
                grs' p s (`failsLeaving` s)
        context "when inner parser succeeds without consuming" $
          it "signals correct parse error" $
            property $ \a w -> do
              let p :: (MonadParsec Void String m) => m ()
                  p = notFollowedBy (setTabWidth w *> return a)
                  s = [a]
              grs p s (`shouldFailWith` err 0 (utok a))
              grs' p s (`failsLeaving` s)
              grs' p s ((`shouldBe` defaultTabWidth) . grabTabWidth)
        context "when inner parser fails without consuming" $ do
          it "succeeds without consuming" $
            property $ \w -> do
              let p :: (MonadParsec Void String m) => m ()
                  p = notFollowedBy (setTabWidth w *> empty)
              grs p "" (`shouldParse` ())
              grs' p "" ((`shouldBe` defaultTabWidth) . grabTabWidth)
          it "hints are not preserved" $
            property $ \a -> do
              let p :: (MonadParsec Void String m) => m ()
                  p = notFollowedBy (many (char a) <* char a) <* empty
                  s = ""
              grs p s (`shouldFailWith` err 0 mempty)
              grs' p s (`failsLeaving` s)
  
      describe "withRecovery" $ do
        context "when inner parser succeeds consuming" $
          it "the result is returned as usual" $
            property $ \a as -> do
              let p :: (MonadParsec Void String m) => m (Maybe Char)
                  p = withRecovery (const $ return Nothing) (pure <$> char a)
                  s = a : as
              grs p s (`shouldParse` Just a)
              grs' p s (`succeedsLeaving` as)
        context "when inner parser fails consuming" $ do
          context "when recovering parser succeeds consuming input" $ do
            it "its result is returned and position is advanced" $
              property $ \a b c as ->
                b /= c ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p =
                        withRecovery
                          (\e -> Left e <$ string (c : as))
                          (Right <$> char a <* char b)
                      s = a : c : as
                  grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))
                  grs' p s (`succeedsLeaving` "")
            it "hints are not preserved" $
              property $ \a b c as ->
                b /= c ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p =
                        withRecovery
                          (\e -> Left e <$ string (c : as))
                          (Right <$> char a <* many (char b) <* char b)
                          <* empty
                      s = a : c : as
                  grs p s (`shouldFailWith` err (length s) mempty)
                  grs' p s (`failsLeaving` "")
          context "when recovering parser fails consuming input" $
            it "the original parse error (and state) is reported" $
              property $ \a b c as ->
                b /= c ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p =
                        withRecovery
                          (\e -> Left e <$ char c <* empty)
                          (Right <$> char a <* char b)
                      s = a : c : as
                  grs p s (`shouldFailWith` err 1 (utok c <> etok b))
                  grs' p s (`failsLeaving` (c : as))
          context "when recovering parser succeeds without consuming" $ do
            it "its result is returned (and state)" $
              property $ \a b c as ->
                b /= c ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p = withRecovery (return . Left) (Right <$> char a <* char b)
                      s = a : c : as
                  grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))
                  grs' p s (`succeedsLeaving` (c : as))
            it "original hints are preserved" $
              property $ \a b c as ->
                b /= c ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p =
                        withRecovery
                          (return . Left)
                          (Right <$> char a <* many (char b) <* char b)
                          <* empty
                      s = a : c : as
                  grs p s (`shouldFailWith` err 1 (etok b))
                  grs' p s (`failsLeaving` (c : as))
          context "when recovering parser fails without consuming" $
            it "the original parse error (and state) is reported" $
              property $ \a b c as ->
                b /= c ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p =
                        withRecovery
                          (\e -> Left e <$ empty)
                          (Right <$> char a <* char b)
                      s = a : c : as
                  grs p s (`shouldFailWith` err 1 (utok c <> etok b))
                  grs' p s (`failsLeaving` (c : as))
        context "when inner parser succeeds without consuming" $
          it "the result is returned as usual" $
            property $ \a s -> do
              let p :: (MonadParsec Void String m) => m (Maybe Char)
                  p = withRecovery (const $ return Nothing) (return a)
              grs p s (`shouldParse` a)
              grs' p s (`succeedsLeaving` s)
        context "when inner parser fails without consuming" $ do
          context "when recovering parser succeeds consuming input" $
            it "its result is returned and position is advanced" $
              property $ \a as -> do
                let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                    p = withRecovery (\e -> Left e <$ string s) empty
                    s = a : as
                grs p s (`shouldParse` Left (err 0 mempty))
                grs' p s (`succeedsLeaving` "")
          context "when recovering parser fails consuming input" $
            it "the original parse error (and state) is reported" $
              property $ \a b as ->
                a /= b ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                      p =
                        withRecovery
                          (\e -> Left e <$ char a <* char b <* empty)
                          (Right <$> empty)
                      s = a : as
                  grs p s (`shouldFailWith` err 0 mempty)
                  grs' p s (`failsLeaving` s)
          context "when recovering parser succeeds without consuming" $ do
            it "its result is returned (and state)" $
              property $ \s -> do
                let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                    p = withRecovery (return . Left) empty
                grs p s (`shouldParse` Left (err 0 mempty))
                grs' p s (`succeedsLeaving` s)
            it "original hints are preserved" $
              property $ \a b as ->
                a /= b ==> do
                  let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) String)
                      p =
                        withRecovery
                          (return . Left)
                          (Right <$> many (char a) <* empty)
                          <* empty
                      s = b : as
                  grs p s (`shouldFailWith` err 0 (etok a))
                  grs' p s (`failsLeaving` s)
          context "when recovering parser fails without consuming" $
            it "the original parse error (and state) is reported" $
              property $ \s -> do
                let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                    p = withRecovery (\e -> Left e <$ empty) empty
                grs p s (`shouldFailWith` err 0 mempty)
                grs' p s (`failsLeaving` s)
        it "works in complex situations too" $
          property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
            let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) String)
                p =
                  let g = count' 1 3 . char
                   in v
                        <$> withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a')
                        <*> g 'c'
                v (Right x) y = Right (x ++ y)
                v (Left m) _ = Left m
                ma = if a < 3 then etok 'a' else mempty
                s = abcRow a b c
                f = flip shouldFailWith
                z = flip shouldParse
                r
                  | a == 0 && b == 0 && c == 0 = f (err 0 (ueof <> etok 'a'))
                  | a == 0 && b == 0 && c > 3 = f (err 0 (utok 'c' <> etok 'a'))
                  | a == 0 && b == 0 = f (err 0 (utok 'c' <> etok 'a'))
                  | a == 0 && b > 3 = f (err 3 (utok 'b' <> etok 'c'))
                  | a == 0 && c == 0 = f (err b (ueof <> etok 'c'))
                  | a == 0 && c > 3 = f (err (b + 3) (utok 'c' <> eeof))
                  | a == 0 = z (Left (err 0 (utok 'b' <> etok 'a')))
                  | a > 3 = f (err 3 (utok 'a' <> etok 'c'))
                  | b == 0 && c == 0 = f (err a (ueof <> etok 'c' <> ma))
                  | b == 0 && c > 3 = f (err (a + 3) (utok 'c' <> eeof))
                  | b == 0 = z (Right s)
                  | otherwise = f (err a (utok 'b' <> etok 'c' <> ma))
            grs (p <* eof) s r
  
      describe "observing" $ do
        context "when inner parser succeeds consuming" $
          it "returns its result in Right" $
            property $ \a as -> do
              let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                  p = observing (char a)
                  s = a : as
              grs p s (`shouldParse` Right a)
              grs' p s (`succeedsLeaving` as)
        context "when inner parser fails consuming" $ do
          it "returns its parse error in Left preserving state" $
            property $ \a b c as ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                    p = observing (char a *> char b)
                    s = a : c : as
                grs p s (`shouldParse` Left (err 1 (utok c <> etok b)))
                grs' p s (`succeedsLeaving` (c : as))
          it "does not create any hints" $
            property $ \a b c as ->
              b /= c ==> do
                let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                    p = observing (char a *> char b) *> empty
                    s = a : c : as
                grs p s (`shouldFailWith` err 1 mempty)
                grs' p s (`failsLeaving` (c : as))
        context "when inner parser succeeds without consuming" $
          it "returns its result in Right" $
            property $ \a s -> do
              let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                  p = observing (return a)
              grs p s (`shouldParse` Right a)
              grs' p s (`succeedsLeaving` s)
        context "when inner parser fails without consuming" $ do
          it "returns its parse error in Left preserving state" $
            property $ \s -> do
              let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) ())
                  p = observing empty
              grs p s (`shouldParse` Left (err 0 mempty))
              grs' p s (`succeedsLeaving` s)
          it "creates correct hints" $
            property $ \a b as ->
              a /= b ==> do
                let p :: (MonadParsec Void String m) => m (Either (ParseError String Void) Char)
                    p = observing (char a) <* empty
                    s = b : as
                grs p s (`shouldFailWith` err 0 (etok a))
                grs' p s (`failsLeaving` (b : as))
  
      describe "eof" $ do
        context "when input stream is empty" $
          it "succeeds" $
            grs eof "" (`shouldParse` ())
        context "when input stream is not empty" $
          it "signals correct error message" $
            property $ \a as -> do
              let s = a : as
              grs eof s (`shouldFailWith` err 0 (utok a <> eeof))
              grs' eof s (`failsLeaving` s)
  
      describe "token" $ do
        let expected = E.singleton . Tokens . nes
            testChar a x = if a == x then Just x else Nothing
        context "when supplied predicate is satisfied" $
          it "succeeds" $
            property $ \a as -> do
              let p :: (MonadParsec Void String m) => m Char
                  p = token (testChar a) (expected a)
                  s = a : as
              grs p s (`shouldParse` a)
              grs' p s (`succeedsLeaving` as)
        context "when supplied predicate is not satisfied" $
          it "signals correct parse error" $
            property $ \a b as ->
              a /= b ==> do
                let p :: (MonadParsec Void String m) => m Char
                    p = token (testChar b) (expected b)
                    s = a : as
                    us = pure (Tokens $ nes a)
                    ps = E.singleton (Tokens $ nes b)
                grs p s (`shouldFailWith` TrivialError 0 us ps)
                grs' p s (`failsLeaving` s)
        context "when stream is empty" $
          it "signals correct parse error" $
            property $ \a -> do
              let p :: (MonadParsec Void String m) => m Char
                  p = token (testChar a) ps
                  us = pure EndOfInput
                  ps = expected a
              grs p "" (`shouldFailWith` TrivialError 0 us ps)
  
      describe "tokens" $ do
        context "when stream is prefixed with given string" $
          it "parses the string" $
            property $ \str s -> do
              let p :: (MonadParsec Void String m) => m String
                  p = tokens (==) str
                  s' = str ++ s
              grs p s' (`shouldParse` str)
              grs' p s' (`succeedsLeaving` s)
        context "when stream is not prefixed with given string" $
          it "signals correct parse error" $
            property $ \str s ->
              not (str `isPrefixOf` s) ==> do
                let p :: (MonadParsec Void String m) => m String
                    p = tokens (==) str
                    z = take (length str) s
                grs p s (`shouldFailWith` err 0 (utoks z <> etoks str))
                grs' p s (`failsLeaving` s)
        context "when matching the empty string" $
          it "eok continuation is used" $
            property $ \str s -> do
              let p :: (MonadParsec Void String m) => m String
                  p = (tokens (==) "" <* empty) <|> pure str
              grs p s (`shouldParse` str)
              grs' p s (`succeedsLeaving` s)
  
      describe "takeWhileP" $ do
        context "when stream is not empty" $
          it "consumes all matching tokens, zero or more" $
            property $ \s ->
              not (null s) ==> do
                let p :: (MonadParsec Void String m) => m String
                    p = takeWhileP Nothing isLetter
                    (z, zs) = DL.span isLetter s
                grs p s (`shouldParse` z)
                grs' p s (`succeedsLeaving` zs)
        context "when stream is empty" $
          it "succeeds returning empty chunk" $ do
            let p :: (MonadParsec Void String m) => m String
                p = takeWhileP Nothing isLetter
            grs p "" (`shouldParse` "")
            grs' p "" (`succeedsLeaving` "")
        context "with two takeWhileP in a row (testing hints)" $ do
          let p :: (MonadParsec Void String m) => m String
              p = do
                void $ takeWhileP (Just "foo") (== 'a')
                void $ takeWhileP (Just "bar") (== 'b')
                empty
          context "when the second one does not consume" $
            it "hints are combined properly" $ do
              let s = "aaa"
                  pe = err 3 (elabel "foo" <> elabel "bar")
              grs p s (`shouldFailWith` pe)
              grs' p s (`failsLeaving` "")
          context "when the second one consumes" $
            it "only hints of the second one affect parse error" $ do
              let s = "aaabbb"
                  pe = err 6 (elabel "bar")
              grs p s (`shouldFailWith` pe)
              grs' p s (`failsLeaving` "")
        context "without label (testing hints)" $
          it "there are no hints" $ do
            let p :: (MonadParsec Void String m) => m String
                p = takeWhileP Nothing (== 'a') <* empty
                s = "aaa"
            grs p s (`shouldFailWith` err 3 mempty)
            grs' p s (`failsLeaving` "")
  
      describe "takeWhile1P" $ do
        context "when stream is prefixed with matching tokens" $
          it "consumes the tokens" $
            property $ \s' -> do
              let p :: (MonadParsec Void String m) => m String
                  p = takeWhile1P Nothing isLetter
                  s = 'a' : s'
                  (z, zs) = DL.span isLetter s
              grs p s (`shouldParse` z)
              grs' p s (`succeedsLeaving` zs)
        context "when stream is not prefixed with at least one matching token" $
          it "signals correct parse error" $
            property $ \s' -> do
              let p :: (MonadParsec Void String m) => m String
                  p = takeWhile1P (Just "foo") isLetter
                  s = '3' : s'
                  pe = err 0 (utok '3' <> elabel "foo")
              grs p s (`shouldFailWith` pe)
              grs' p s (`failsLeaving` s)
        context "when stream is empty" $ do
          context "with label" $
            it "signals correct parse error" $ do
              let p :: (MonadParsec Void String m) => m String
                  p = takeWhile1P (Just "foo") isLetter
                  pe = err 0 (ueof <> elabel "foo")
              grs p "" (`shouldFailWith` pe)
              grs' p "" (`failsLeaving` "")
          context "without label" $
            it "signals correct parse error" $ do
              let p :: (MonadParsec Void String m) => m String
                  p = takeWhile1P Nothing isLetter
                  pe = err 0 ueof
              grs p "" (`shouldFailWith` pe)
              grs' p "" (`failsLeaving` "")
        context "with two takeWhile1P in a row (testing hints)" $ do
          let p :: (MonadParsec Void String m) => m String
              p = do
                void $ takeWhile1P (Just "foo") (== 'a')
                void $ takeWhile1P (Just "bar") (== 'b')
                empty
          context "when the second one does not consume" $
            it "hints are combined properly" $ do
              let s = "aaa"
                  pe = err 3 (ueof <> elabel "foo" <> elabel "bar")
              grs p s (`shouldFailWith` pe)
              grs' p s (`failsLeaving` "")
          context "when the second one consumes" $
            it "only hints of the second one affect parse error" $ do
              let s = "aaabbb"
                  pe = err 6 (elabel "bar")
              grs p s (`shouldFailWith` pe)
              grs' p s (`failsLeaving` "")
        context "without label (testing hints)" $
          it "there are no hints" $ do
            let p :: (MonadParsec Void String m) => m String
                p = takeWhile1P Nothing (== 'a') <* empty
                s = "aaa"
            grs p s (`shouldFailWith` err 3 mempty)
            grs' p s (`failsLeaving` "")
  
      describe "takeP" $ do
        context "when taking 0 tokens" $ do
          context "when stream is empty" $
            it "succeeds returning zero-length chunk" $ do
              let p :: (MonadParsec Void String m) => m String
                  p = takeP Nothing 0
              grs p "" (`shouldParse` "")
          context "when stream is not empty" $
            it "succeeds returning zero-length chunk" $
              property $ \s ->
                not (null s) ==> do
                  let p :: (MonadParsec Void String m) => m String
                      p = takeP Nothing 0
                  grs p s (`shouldParse` "")
                  grs' p s (`succeedsLeaving` s)
        context "when taking <0 tokens" $ do
          context "when stream is empty" $
            it "succeeds returning zero-length chunk" $
              property $ \(Negative n) -> do
                let p :: (MonadParsec Void String m) => m String
                    p = takeP Nothing n
                grs p "" (`shouldParse` "")
          context "when stream is not empty" $
            it "succeeds returning zero-length chunk" $
              property $ \(Negative n) s ->
                not (null s) ==> do
                  let p :: (MonadParsec Void String m) => m String
                      p = takeP Nothing n
                  grs p s (`shouldParse` "")
                  grs' p s (`succeedsLeaving` s)
        context "when taking >0 tokens" $ do
          context "when stream is empty" $ do
            context "with label" $
              it "signals correct parse error" $
                property $ \(Positive n) -> do
                  let p :: (MonadParsec Void String m) => m String
                      p = takeP (Just "foo") n
                      pe = err 0 (ueof <> elabel "foo")
                  grs p "" (`shouldFailWith` pe)
                  grs' p "" (`failsLeaving` "")
            context "without label" $
              it "signals correct parse error" $
                property $ \(Positive n) -> do
                  let p :: (MonadParsec Void String m) => m String
                      p = takeP Nothing n
                      pe = err 0 ueof
                  grs p "" (`shouldFailWith` pe)
          context "when stream has not enough tokens" $
            it "signals correct parse error" $
              property $ \(Positive n) s -> do
                let p :: (MonadParsec Void String m) => m String
                    p = takeP (Just "foo") n
                    m = length s
                    pe = err m (ueof <> elabel "foo")
                unless (length s < n && not (null s)) discard
                grs p s (`shouldFailWith` pe)
                grs' p s (`failsLeaving` s)
          context "when stream has enough tokens" $
            it "succeeds returning the extracted tokens" $
              property $ \(Positive n) s ->
                length s >= n ==> do
                  let p :: (MonadParsec Void String m) => m String
                      p = takeP (Just "foo") n
                      (s0, s1) = splitAt n s
                  grs p s (`shouldParse` s0)
                  grs' p s (`succeedsLeaving` s1)
        context "when failing right after takeP (testing hints)" $
          it "there are no hints to influence the parse error" $
            property $ \(Positive n) s ->
              length s >= n ==> do
                let p :: (MonadParsec Void String m) => m String
                    p = takeP (Just "foo") n <* empty
                    pe = err n mempty
                grs p s (`shouldFailWith` pe)
                grs' p s (`failsLeaving` drop n s)
  
    describe "signaling parse errors" $ do
      describe "failure" $
        it "signals correct parse error" $
          property $ \us ps -> do
            let p :: (MonadParsec Void String m) => m ()
                p = void (failure us ps)
            grs p "" (`shouldFailWith` TrivialError 0 us ps)
  
      describe "fancyFailure" $
        it "singals correct parse error" $
          property $ \xs -> do
            let p :: (MonadParsec Void String m) => m ()
                p = void (fancyFailure xs)
            grs p "" (`shouldFailWith` FancyError 0 xs)
  
      describe "unexpected" $
        it "signals correct parse error" $
          property $ \item -> do
            let p :: (MonadParsec Void String m) => m ()
                p = void (unexpected item)
            grs p "" (`shouldFailWith` TrivialError 0 (pure item) E.empty)
  
      describe "customFailure" $
        it "signals correct parse error" $
          property $ \n st -> do
            let p :: (MonadParsec Int String m) => m ()
                p = void (customFailure n)
                xs = E.singleton (ErrorCustom n)
            runParser p "" (stateInput st) `shouldFailWith` FancyError 0 xs
            runParser' p st `failsLeaving` stateInput st
  
      describe "region" $ do
        let f o' = \case
              TrivialError o us ps ->
                FancyError
                  (max o o')
                  (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)
              FancyError o xs ->
                FancyError
                  (max o o')
                  (E.singleton . ErrorCustom $ E.size xs)
        context "when inner parser succeeds" $ do
          it "delayed parse errors get updated correctly" $
            property $ \st es0 es1 es2 o' n -> do
              let p :: Parsec Int String Int
                  p = do
                    forM_ (NE.reverse es0) registerParseError
                    region (f o') $
                      forM_ (NE.reverse es1) registerParseError
                    forM_ (NE.reverse es2) registerParseError
                    return n
                  es = es2 <> fmap (f o') es1 <> es0
                  st' =
                    st
                      { stateParseErrors = NE.toList es
                      }
              runParser' p st
                `shouldBe` ( st',
                             Left (mkBundle st es)
                           )
        context "when inner parser fails" $ do
          it "delayed and normal parse errors get updated correctly" $
            property $ \st es0 es1 e o' -> do
              let p :: Parsec Int String ()
                  p = do
                    forM_ (NE.reverse es0) registerParseError
                    region (f o') $ do
                      forM_ (NE.reverse es1) registerParseError
                      void (parseError e)
                  es = fmap (f o') es1 <> es0
                  st' =
                    st
                      { stateParseErrors = NE.toList es
                      }
              runParser' p st
                `shouldBe` ( st',
                             Left (mkBundle st (nes (f o' e) <> es))
                           )
  
      describe "registerParseError" $ do
        it "immediately fails with given parse error" $
          property $ \st es -> do
            let p :: (MonadParsec Void String m) => m ()
                p = forM_ (NE.reverse es) registerParseError
                st' =
                  st
                    { stateParseErrors = NE.toList es
                    }
            runParser' p st
              `shouldBe` ( st',
                           Left (mkBundle st es)
                         )
  
      describe "registerFailure" $
        it "signals correct parse error" $
          property $ \us ps -> do
            let p :: (MonadParsec Void String m) => m ()
                p = void (registerFailure us ps)
            grs p "" (`shouldFailWith` TrivialError 0 us ps)
  
      describe "reisterFancyFailure" $
        it "singals correct parse error" $
          property $ \xs -> do
            let p :: (MonadParsec Void String m) => m ()
                p = void (registerFancyFailure xs)
            grs p "" (`shouldFailWith` FancyError 0 xs)
  
    describe "derivatives from primitive combinators" $ do
      -- NOTE 'single' is tested via 'char' in "Text.Megaparsec.Char" and
      -- "Text.Megaparsec.Byte".
  
      describe "anySingle" $ do
        let p :: (MonadParsec Void String m) => m Char
            p = anySingle
        context "when stream is not empty" $
          it "succeeds consuming next character in the stream" $
            property $ \ch s -> do
              let s' = ch : s
              grs p s' (`shouldParse` ch)
              grs' p s' (`succeedsLeaving` s)
        context "when stream is empty" $
          it "signals correct parse error" $
            grs p "" (`shouldFailWith` err 0 ueof)
  
      describe "anySingleBut" $ do
        context "when stream begins with the character specified as argument" $
          it "signals correct parse error" $
            property $ \ch s' -> do
              let p :: (MonadParsec Void String m) => m Char
                  p = anySingleBut ch
                  s = ch : s'
              grs p s (`shouldFailWith` err 0 (utok ch))
              grs' p s (`failsLeaving` s)
        context "when stream does not begin with the character specified as argument" $
          it "parses first character in the stream" $
            property $ \ch s ->
              not (null s) && ch /= head s ==> do
                let p :: (MonadParsec Void String m) => m Char
                    p = anySingleBut ch
                grs p s (`shouldParse` head s)
                grs' p s (`succeedsLeaving` tail s)
        context "when stream is empty" $
          it "signals correct parse error" $
            grs (anySingleBut 'a') "" (`shouldFailWith` err 0 ueof)
  
      describe "oneOf" $ do
        context "when stream begins with one of specified characters" $
          it "parses the character" $
            property $ \(NonEmpty chs) (NonNegative n) s -> do
              let ch = chs !! (n `rem` length chs)
                  s' = ch : s
              grs (oneOf chs) s' (`shouldParse` ch)
              grs' (oneOf chs) s' (`succeedsLeaving` s)
        context "when stream does not begin with any of specified characters" $
          it "signals correct parse error" $
            property $ \chs ch s ->
              ch `notElem` (chs :: String) ==> do
                let s' = ch : s
                grs (oneOf chs) s' (`shouldFailWith` err 0 (utok ch))
                grs' (oneOf chs) s' (`failsLeaving` s')
        context "when stream is empty" $
          it "signals correct parse error" $
            property $ \chs ->
              grs (oneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)
  
      describe "noneOf" $ do
        context "when stream does not begin with any of specified characters" $
          it "parses the character" $
            property $ \chs ch s ->
              ch `notElem` (chs :: String) ==> do
                let s' = ch : s
                grs (noneOf chs) s' (`shouldParse` ch)
                grs' (noneOf chs) s' (`succeedsLeaving` s)
        context "when stream begins with one of specified characters" $
          it "signals correct parse error" $
            property $ \(NonEmpty chs) (NonNegative n) s -> do
              let ch = chs !! (n `rem` length chs)
                  s' = ch : s
              grs (noneOf chs) s' (`shouldFailWith` err 0 (utok ch))
              grs' (noneOf chs) s' (`failsLeaving` s')
        context "when stream is empty" $
          it "signals correct parse error" $
            property $ \chs ->
              grs (noneOf (chs :: String)) "" (`shouldFailWith` err 0 ueof)
  
      -- NOTE 'chunk' is tested via 'string' in "Text.Megaparsec.Char" and
      -- "Text.Megaparsec.Byte".
  
      describe "match" $
        it "return consumed tokens along with the result" $
          property $ \str -> do
            let p = match (string str)
            prs p str `shouldParse` (str, str)
            prs' p str `succeedsLeaving` ""
  
      describe "takeRest" $
        it "returns rest of the input" $
          property $ \st@State {..} -> do
            let p :: Parser String
                p = takeRest
                st' =
                  st
                    { stateInput = [],
                      stateOffset = stateOffset + length stateInput,
                      statePosState = statePosState
                    }
            runParser' p st `shouldBe` (st', Right stateInput)
  
      describe "atEnd" $ do
        let p, p' :: Parser Bool
            p = atEnd
            p' = p <* empty
        context "when stream is empty" $ do
          it "returns True" $
            prs p "" `shouldParse` True
          it "does not produce hints" $
            prs p' "" `shouldFailWith` err 0 mempty
        context "when stream is not empty" $ do
          it "returns False" $
            property $ \s ->
              not (null s) ==> do
                prs p s `shouldParse` False
                prs' p s `succeedsLeaving` s
          it "does not produce hints" $
            property $ \s ->
              not (null s) ==> do
                prs p' s `shouldFailWith` err 0 mempty
                prs' p' s `failsLeaving` s
  
    describe "combinators for manipulating parser state" $ do
      describe "setInput and getInput" $
        it "sets input and gets it back" $
          property $ \s -> do
            let p = do
                  st0 <- getInput
                  guard (null st0)
                  setInput s
                  result <- string s
                  st1 <- getInput
                  guard (null st1)
                  return result
            prs p "" `shouldParse` s
  
      describe "getSourcePos" $
        it "sets position and gets it back" $
          property $ \st -> do
            let p :: Parser SourcePos
                p = getSourcePos
                pst' = snd $ reachOffset (stateOffset st) (statePosState st)
                spos = pstateSourcePos pst'
            runParser' p st `shouldBe` (st {statePosState = pst'}, Right spos)
  
      describe "setOffset and getOffset" $
        it "sets number of processed tokens and gets it back" $
          property $ \o -> do
            let p = setOffset o >> getOffset
            prs p "" `shouldParse` o
  
      describe "setParserState and getParserState" $
        it "sets parser state and gets it back" $
          property $ \s1 s2 -> do
            let p :: (MonadParsec Void String m) => m (State String Void)
                p = do
                  st <- getParserState
                  guard (st == initialState s)
                  setParserState s1
                  updateParserState (f s2)
                  getParserState <* setInput ""
                f (State s1' o pst de1) (State s2' _ _ de2) =
                  State (max s1' s2') o pst (de1 <> de2)
                s = ""
            grs p s (`shouldParse` f s2 s1)
  
    describe "running a parser" $ do
      describe "parseMaybe" $
        it "returns result on success and Nothing on failure" $
          property $ \s s' -> do
            let p = string s' :: Parser String
            parseMaybe p s
              `shouldBe` if s == s' then Just s else Nothing
  
      describe "runParser'" $
        it "works" $
          property $ \st s -> do
            let p = string s
            runParser' p st `shouldBe` emulateStrParsing st s
  
      describe "runParserT'" $
        it "works" $
          property $ \st s -> do
            let p = string s
            runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s
  
    describe "MonadParsec instance of ReaderT" $ do
      describe "try" $
        it "generally works" $
          property $ \pre ch1 ch2 -> do
            let s1 = pre : [ch1]
                s2 = pre : [ch2]
                getS1 = asks fst
                getS2 = asks snd
                p = try (g =<< getS1) <|> (g =<< getS2)
                g = sequence . fmap char
                s = [pre]
            prs (runReaderT p (s1, s2)) s
              `shouldFailWith` err 1 (ueof <> etok ch1 <> etok ch2)
  
      describe "notFollowedBy" $
        it "generally works" $
          property $ \(NonNegative a) (NonNegative b) (NonNegative c) -> do
            let p = many (char =<< ask) <* notFollowedBy eof <* many anySingle
                s = abcRow a b c
            if b > 0 || c > 0
              then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'
              else
                prs (runReaderT p 'a') s
                  `shouldFailWith` err a (ueof <> etok 'a')
  
    describe "MonadParsec instance of lazy StateT" $ do
      describe "(<|>)" $
        it "generally works" $
          property $ \n -> do
            let p =
                  L.put n
                    >> ((L.modify (* 2) >> void (string "xxx")) <|> return ())
                    >> L.get
            prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)
  
      describe "lookAhead" $
        it "generally works" $
          property $ \n -> do
            let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get
            prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)
  
      describe "notFollowedBy" $
        it "generally works" $
          property $ \n -> do
            let p = do
                  L.put n
                  let notEof = notFollowedBy (L.modify (* 2) >> eof)
                  some (try (anySingle <* notEof)) <* char 'x'
            prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)
  
      describe "observing" $ do
        context "when inner parser succeeds" $
          it "can affect state" $
            property $ \m n -> do
              let p = do
                    L.put m
                    observing (L.modify (+ n))
              prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)
        context "when inner parser fails" $
          it "cannot affect state" $
            property $ \m n -> do
              let p = do
                    L.put m
                    observing (L.modify (+ n) <* empty)
              prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)
  
    describe "MonadParsec instance of strict StateT" $ do
      describe "(<|>)" $
        it "generally works" $
          property $ \n -> do
            let p =
                  S.put n
                    >> ((S.modify (* 2) >> void (string "xxx")) <|> return ())
                    >> S.get
            prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)
  
      describe "lookAhead" $
        it "generally works" $
          property $ \n -> do
            let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get
            prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)
  
      describe "notFollowedBy" $
        it "generally works" $
          property $ \n -> do
            let p = do
                  S.put n
                  let notEof = notFollowedBy (S.modify (* 2) >> eof)
                  some (try (anySingle <* notEof)) <* char 'x'
            prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)
  
      describe "observing" $ do
        context "when inner parser succeeds" $
          it "can affect state" $
            property $ \m n -> do
              let p = do
                    S.put m
                    observing (L.modify (+ n))
              prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)
        context "when inner parser fails" $
          it "cannot affect state" $
            property $ \m n -> do
              let p = do
                    S.put m
                    observing (L.modify (+ n) <* empty)
              prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)
  
    describe "MonadParsec instance of lazy WriterT" $ do
      it "generally works" $
        property $ \pre post -> do
          let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x
              loggedEof = eof >> L.tell "EOF"
              p = do
                L.tell pre
                cs <-
                  L.censor (fmap toUpper) $
                    some (try (loggedLetter <* notFollowedBy loggedEof))
                L.tell post
                void loggedLetter
                return cs
          prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")
  
      describe "lookAhead" $
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = lookAhead (L.tell [w])
            prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
  
      describe "notFollowedBy" $
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = notFollowedBy (L.tell [w] <* char 'a')
            prs (L.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
  
      describe "observing" $ do
        context "when inner parser succeeds" $
          it "can affect log" $
            property $ \n -> do
              let p = observing (L.tell $ Sum n)
              prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)
        context "when inner parser fails" $
          it "cannot affect log" $
            property $ \n -> do
              let p = observing (L.tell (Sum n) <* empty)
              prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)
  
    describe "MonadParsec instance of strict WriterT" $ do
      it "generally works" $
        property $ \pre post -> do
          let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x
              loggedEof = eof >> S.tell "EOF"
              p = do
                S.tell pre
                cs <-
                  L.censor (fmap toUpper) $
                    some (try (loggedLetter <* notFollowedBy loggedEof))
                S.tell post
                void loggedLetter
                return cs
          prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")
  
      describe "lookAhead" $
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = lookAhead (S.tell [w])
            prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
  
      describe "notFollowedBy" $
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = notFollowedBy (S.tell [w] <* char 'a')
            prs (S.runWriterT p) "" `shouldParse` ((), mempty :: [Int])
  
      describe "observing" $ do
        context "when inner parser succeeds" $
          it "can affect log" $
            property $ \n -> do
              let p = observing (S.tell $ Sum n)
              prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)
        context "when inner parser fails" $
          it "cannot affect log" $
            property $ \n -> do
              let p = observing (S.tell (Sum n) <* empty)
              prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)
  
    describe "MonadParsec instance of lazy RWST" $ do
      describe "label" $
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = label "a" ((,) <$> L.ask <*> L.get)
            prs (L.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
  
      describe "try" $
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = try ((,) <$> L.ask <*> L.get)
            prs (L.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
  
      describe "lookAhead" $ do
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = lookAhead ((,) <$> L.ask <*> L.get)
            prs (L.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = lookAhead (L.tell [w])
            prs (L.runRWST p (0 :: Int) (0 :: Int)) ""
              `shouldParse` ((), 0, mempty :: [Int])
        it "does not allow to influence state outside it" $
          property $ \s0 s1 ->
            (s0 /= s1) ==> do
              let p = lookAhead (L.put s1)
              prs (L.runRWST p (0 :: Int) (s0 :: Int)) ""
                `shouldParse` ((), s0, mempty :: [Int])
  
      describe "notFollowedBy" $ do
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = notFollowedBy (L.tell [w] <* char 'a')
            prs (L.runRWST p (0 :: Int) (0 :: Int)) ""
              `shouldParse` ((), 0, mempty :: [Int])
        it "does not allow to influence state outside it" $
          property $ \s0 s1 ->
            (s0 /= s1) ==> do
              let p = notFollowedBy (L.put s1 <* char 'a')
              prs (L.runRWST p (0 :: Int) (s0 :: Int)) ""
                `shouldParse` ((), s0, mempty :: [Int])
  
      describe "withRecovery" $ do
        it "allows main parser to access reader context and state inside it" $
          property $ \r s -> do
            let p = withRecovery (const empty) ((,) <$> L.ask <*> L.get)
            prs (L.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
        it "allows recovering parser to access reader context and state inside it" $
          property $ \r s -> do
            let p = withRecovery (\_ -> (,) <$> L.ask <*> L.get) empty
            prs (L.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
  
      describe "observing" $ do
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = observing ((,) <$> L.ask <*> L.get)
            prs (L.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` (Right (r, s), s, mempty :: [Int])
        context "when the inner parser fails" $
          it "backtracks state" $
            property $ \r s0 s1 ->
              (s0 /= s1) ==> do
                let p = observing (L.put s1 <* empty)
                prs (L.runRWST p (r :: Int) (s0 :: Int)) ""
                  `shouldParse` (Left (err 0 mempty), s0, mempty :: [Int])
  
    describe "MonadParsec instance of strict RWST" $ do
      describe "label" $
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = label "a" ((,) <$> S.ask <*> S.get)
            prs (S.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
  
      describe "try" $
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = try ((,) <$> S.ask <*> S.get)
            prs (S.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
  
      describe "lookAhead" $ do
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = lookAhead ((,) <$> S.ask <*> S.get)
            prs (S.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = lookAhead (S.tell [w])
            prs (S.runRWST p (0 :: Int) (0 :: Int)) ""
              `shouldParse` ((), 0, mempty :: [Int])
        it "does not allow to influence state outside it" $
          property $ \s0 s1 ->
            (s0 /= s1) ==> do
              let p = lookAhead (S.put s1)
              prs (S.runRWST p (0 :: Int) (s0 :: Int)) ""
                `shouldParse` ((), s0, mempty :: [Int])
  
      describe "notFollowedBy" $ do
        it "discards what writer tells inside it" $
          property $ \w -> do
            let p = notFollowedBy (S.tell [w] <* char 'a')
            prs (S.runRWST p (0 :: Int) (0 :: Int)) ""
              `shouldParse` ((), 0, mempty :: [Int])
        it "does not allow to influence state outside it" $
          property $ \s0 s1 ->
            (s0 /= s1) ==> do
              let p = notFollowedBy (S.put s1 <* char 'a')
              prs (S.runRWST p (0 :: Int) (s0 :: Int)) ""
                `shouldParse` ((), s0, mempty :: [Int])
  
      describe "withRecovery" $ do
        it "allows main parser to access reader context and state inside it" $
          property $ \r s -> do
            let p = withRecovery (const empty) ((,) <$> S.ask <*> S.get)
            prs (S.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
        it "allows recovering parser to access reader context and state inside it" $
          property $ \r s -> do
            let p = withRecovery (\_ -> (,) <$> S.ask <*> S.get) empty
            prs (S.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` ((r, s), s, mempty :: [Int])
  
      describe "observing" $ do
        it "allows to access reader context and state inside it" $
          property $ \r s -> do
            let p = observing ((,) <$> S.ask <*> S.get)
            prs (S.runRWST p (r :: Int) (s :: Int)) ""
              `shouldParse` (Right (r, s), s, mempty :: [Int])
        context "when the inner parser fails" $
          it "backtracks state" $
            property $ \r s0 s1 ->
              (s0 /= s1) ==> do
                let p = observing (S.put s1 <* empty)
                prs (S.runRWST p (r :: Int) (s0 :: Int)) ""
                  `shouldParse` (Left (err 0 mempty), s0, mempty :: [Int])
  
      describe "mkParsec" $
        it "enables defining new primitives" $ do
          -- This example lifts breakOn from text, although in order to re-use
          -- the machinery that we have here it parses String, hence
          -- conversions. The parser always succeeds.
          let breakOn end = mkParsec $ \s ->
                let (pre, post) = T.breakOn end (T.pack $ stateInput s)
                 in Internal.Reply
                      ( s
                          { stateInput = T.unpack post,
                            stateOffset = stateOffset s + T.length pre
                          }
                      )
                      ( if T.null pre
                          then Internal.NotConsumed
                          else Internal.Consumed
                      )
                      (Internal.OK mempty (T.unpack pre))
          prs (breakOn "x") "abxcd" `shouldParse` "ab"
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  instance ShowErrorComponent Int where
    showErrorComponent = show
  
  emulateStrParsing ::
    State String Void ->
    String ->
    (State String Void, Either (ParseErrorBundle String Void) String)
  emulateStrParsing st@(State i o pst de) s =
    if s == take l i
      then
        ( State (drop l i) (o + l) pst de,
          Right s
        )
      else
        ( st,
          Left (mkBundle st (nes (err o (etoks s <> utoks (take l i)))))
        )
    where
      l = length s
  
  eqParser ::
    (Eq a, Eq (Token s), Eq s) =>
    Parsec Void s a ->
    Parsec Void s a ->
    s ->
    Bool
  eqParser p1 p2 s = runParser p1 "" s == runParser p2 "" s
  
  mkBundle ::
    State s e ->
    NE.NonEmpty (ParseError s e) ->
    ParseErrorBundle s e
  mkBundle s es =
    ParseErrorBundle
      { bundleErrors = NE.sortWith errorOffset es,
        bundlePosState = statePosState s
      }
  
  grabTabWidth :: (State a e, b) -> Pos
  grabTabWidth = pstateTabWidth . statePosState . fst
  