{-# LANGUAGE CPP               #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiWayIf        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE RecursiveDo       #-}
{-# LANGUAGE TypeFamilies      #-}
{-# OPTIONS -fno-warn-orphans  #-}

module Text.MegaparsecSpec (spec) where

import Control.Monad.Cont
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Char (toUpper, isLetter)
import Data.Foldable (asum, concat)
import Data.Function (on)
import Data.List (isPrefixOf)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Data.Monoid
import Data.Proxy
import Data.String
import Data.Void
import Prelude hiding (span, concat)
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 Control.Monad.RWS.Lazy      as L
import qualified Control.Monad.RWS.Strict    as S
import qualified Control.Monad.State.Lazy    as L
import qualified Control.Monad.State.Strict  as S
import qualified Control.Monad.Writer.Lazy   as L
import qualified Control.Monad.Writer.Strict as S
import qualified Data.List                   as DL
import qualified Data.List.NonEmpty          as NE
import qualified Data.Semigroup              as G
import qualified Data.Set                    as E
import qualified Data.Text                   as T
import qualified Data.ByteString             as BS

#if !MIN_VERSION_base(4,8,0)
import Control.Applicative hiding (many, some)
#endif

#if !MIN_VERSION_QuickCheck(2,8,2)
instance (Arbitrary a, Ord a) => Arbitrary (E.Set a) where
  arbitrary = E.fromList <$> arbitrary
  shrink    = fmap E.fromList . shrink . E.toList
#endif

spec :: Spec
spec = do

  describe "position in custom stream" $ do

    describe "eof" $
      it "updates position in stream correctly" $
        property $ \st -> (not . null . stateInput) st ==> do
          let p = eof :: CustomParser ()
              h = head (stateInput st)
              apos = let (_:|z) = statePos st in spanStart h :| z
          runParser' p st `shouldBe`
            ( st { statePos = apos }
            , Left (err apos $ utok h <> eeof) )

    describe "token" $ do
      context "when input stream is empty" $
        it "signals correct parse error" $
          property $ \st'@State {..} span -> do
            let p = pSpan span
                st = (st' :: State [Span]) { stateInput = [] }
            runParser' p st `shouldBe`
              ( st
              , Left (err statePos $ ueof <> etok span) )
      context "when head of stream matches" $
        it "updates parser state correctly" $
          property $ \st'@State {..} span -> do
            let p = pSpan span
                st = st' { stateInput = span : stateInput }
                npos = spanEnd span :| NE.tail statePos
            runParser' p st `shouldBe`
              ( st { statePos             = npos
                   , stateTokensProcessed = stateTokensProcessed + 1
                   , stateInput           = stateInput }
              , Right span )
      context "when head of stream does not match" $ do
        let checkIt s span =
              let ms = listToMaybe s
              in isJust ms && (spanBody <$> ms) /= Just (spanBody span)
        it "signals correct parse error" $
          property $ \st@State {..} span -> checkIt stateInput span ==> do
            let p = pSpan span
                h = head stateInput
                apos = spanStart h :| NE.tail statePos
            runParser' p st `shouldBe`
              ( st { statePos = apos }
              , Left (err apos $ utok h <> etok span))

    describe "tokens" $
      it "updates position in stream correctly" $
        property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do
          let p = tokens compareTokens ts :: CustomParser [Span]
              compareTokens = (==) `on` fmap spanBody
              compareToken  = (==) `on` spanBody
              il = length . takeWhile id $ zipWith compareToken stateInput ts
              tl = length ts
              consumed = take il stateInput
              (apos, npos) =
                let (pos:|z) = statePos
                    pxy = Proxy :: Proxy [Span]
                in ( positionAt1 pxy pos (head stateInput) :| z
                   , advanceN pxy stateTabWidth pos consumed :| z )
          if | null ts -> runParser' p st `shouldBe` (st, Right [])
             | null stateInput -> runParser' p st `shouldBe`
               ( st
               , Left (err statePos $ ueof <> etoks ts) )
             | il == tl -> runParser' p st `shouldBe`
               ( st { statePos             = npos
                    , stateTokensProcessed = stateTokensProcessed + fromIntegral tl
                    , stateInput           = drop tl stateInput }
               , Right consumed )
             | otherwise -> runParser' p st `shouldBe`
               ( st { statePos = apos }
               , Left (err apos $ utoks (take tl stateInput) <> etoks ts) )

    describe "takeWhileP" $
      it "updates position in stream correctly" $
        property $ \st@State {..} -> do
          let p = takeWhileP Nothing (const True) :: CustomParser [Span]
              st' = st
                { stateInput = []
                , statePos   =
                    case stateInput of
                      [] -> statePos
                      xs -> let _:|z = statePos in spanEnd (last xs) :| z
                , stateTokensProcessed =
                    stateTokensProcessed + length stateInput }
          runParser' p st `shouldBe` (st', Right stateInput)

    describe "takeWhile1P" $ do
      context "when stream is prefixed with matching tokens" $
        it "updates position in stream correctly" $
          property $ \st@State {..} -> not (null stateInput) ==> do
            let p = takeWhile1P Nothing (const True) :: CustomParser [Span]
                st' = st
                  { stateInput = []
                  , statePos   =
                      case stateInput of
                        [] -> statePos
                        xs -> let _:|z = statePos in spanEnd (last xs) :| z
                  , stateTokensProcessed =
                      stateTokensProcessed + length stateInput }
            runParser' p st `shouldBe` (st', Right stateInput)
      context "when stream is not prefixed with at least one matching token" $
        it "updates position in stream correctly" $
          property $ \st@State {..} -> do
            let p = takeWhile1P Nothing (const False) :: CustomParser [Span]
            fst (runParser' p st) `shouldBe` st

    describe "takeP" $ do
      context "when stream has enough tokens" $
        it "updates position in stream correctly" $
          property $ \st@State {..} -> not (null stateInput) ==> do
            let p = takeP Nothing (length stateInput) :: CustomParser [Span]
                st' = st
                  { stateInput = []
                  , statePos   =
                      case stateInput of
                        [] -> statePos
                        xs -> let _:|z = statePos in spanEnd (last xs) :| z
                  , stateTokensProcessed =
                      stateTokensProcessed + length stateInput }
            runParser' p st `shouldBe` (st', Right stateInput)
      context "when stream has not enough tokens" $
        it "updates position in stream correctly" $
          property $ \st@State {..} -> not (null stateInput) ==> do
            let p = takeP Nothing (1 + length stateInput) :: CustomParser [Span]
                (pos:|z) = statePos
                st' = st
                  { statePos = positionAtN
                      (Proxy :: Proxy [Span]) pos stateInput :| z }
            fst (runParser' p st) `shouldBe` st'

    describe "getNextTokenPosition" $ do
      context "when input stream is empty" $
        it "returns Nothing" $
          property $ \st' -> do
            let p :: CustomParser (Maybe SourcePos)
                p = getNextTokenPosition
                st = (st' :: State [Span]) { stateInput = [] }
            runParser' p st `shouldBe` (st, Right Nothing)
      context "when input stream is not empty" $
        it "return the position of start of the next token" $
           property $ \st' h -> do
             let p :: CustomParser (Maybe SourcePos)
                 p = getNextTokenPosition
                 st = st' { stateInput = h : stateInput st' }
             runParser' p st `shouldBe` (st, (Right . Just . spanStart) h)

  describe "ParsecT Semigroup instance" $
    it "the associative operation works" $
      property $ \a b -> do
        let p = pure [a] G.<> 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
          (string s)
          (fromString s)
          (i :: String)
      it "for Text" $ property $ \s i ->
        eqParser
          (string (T.pack s))
          (fromString s)
          (i :: T.Text)
      it "for ByteString" $ property $ \s i ->
        eqParser
          (string (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 (posN (4 :: Int) s) 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 = string s0 <|> string 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 posI
                (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 (posN (1 :: Int) s) (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 posI (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 posI (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 $ \a' b' c' -> do
            let [a,b,c] = getNonNegative <$> [a',b',c']
                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 $ \a' b' c' -> do
            let [a,b,c] = getNonNegative <$> [a',b',c']
                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 posI
            (utok 'c' <> etok 'a' <> etok 'b' <> eeof)
      context "when the argument parser succeeds without consuming" $
        it "is run nevertheless" $
          property $ \n' -> do
            let n = getSmall (getNonNegative n') :: Integer
                p = void . many $ do
                  x <- S.get
                  if x < n then S.modify (+ 1) else empty
                v :: S.State Integer (Either (ParseError Char 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 $ \a' b' c' -> do
            let a = getPositive a'
                [b,c] = getNonNegative <$> [b',c']
                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 $ \a' b' c' -> do
            let [a,b,c] = getNonNegative <$> [a',b',c']
                p = some (char 'd')
                s = abcRow a b c ++ "g"
            prs  p s `shouldFailWith` err posI (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 posI (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 posI (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 posI (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
          :: (MonadParsec e s m, MonadFix m)
          => ((SourcePos,SourcePos) -> m a)
          -> m a
        withRange f = do
          Just p1 <- getNextTokenPosition
          rec
            r <- f (p1, p2)
            p2 <- getPosition
          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" $
      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

    describe "local" $
      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)

  describe "ParsecT MonadState instance" $ do

    describe "get" $
      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
    describe "put" $
      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

  describe "ParsecT MonadCont instance" $

    describe "callCC" $
      it "works properly" $
        property $ \a b -> do
          let p :: ParsecT Void String (Cont (Either (ParseError Char 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 "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 posI 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 posI xs)

    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 (posN (1 :: Int) s) mempty)
              grs' p s (`failsLeaving` "")
        context "inner parser produces hints" $
          it "replaces the last hint with “the rest of <label>”" $
            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 (posN (1 :: Int) s) (elabel $ "the rest of " ++ lbl))
              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 (posN (1 :: Int) s) (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 posI 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 posI (elabel lbl))
      context "when inner parser fails without consuming" $
        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 posI (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 (posN (1 :: Int) s) 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 (posN (1 :: Int) s) 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 (posN (1 :: Int) s) (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 posI 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 posI 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 posI 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 (posN (1 :: Int) s) (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 posI 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 posI mempty)
            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)

    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 posI 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 (posN (1 :: Int) s) (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 posI 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 posI 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 posI (utok a))
            grs' p s (`failsLeaving` s)
            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
      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) . stateTabWidth . fst)
        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 posI 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 posI (utok a))
            grs' p s (`failsLeaving` s)
            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)
      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) . stateTabWidth . fst)
        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 posI 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 Char 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 (posN (1 :: Int) s) (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 Char 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 (posN (length s) 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 Char Void) Char)
                  p = withRecovery (\e -> Left e <$ char c <* empty)
                        (Right <$> char a <* char b)
                  s = a : c : as
              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (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 Char Void) Char)
                  p = withRecovery (return . Left) (Right <$> char a <* char b)
                  s = a : c : as
              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (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 Char Void) Char)
                  p = withRecovery (return . Left)
                        (Right <$> char a <* many (char b) <* char b) <* empty
                  s = a : c : as
              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (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 Char Void) Char)
                  p = withRecovery (\e -> Left e <$ empty)
                        (Right <$> char a <* char b)
                  s = a : c : as
              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (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 Char Void) Char)
                  p = withRecovery (\e -> Left e <$ string s) empty
                  s = a : as
              grs  p s (`shouldParse` Left (err posI 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 Char Void) Char)
                  p = withRecovery (\e -> Left e <$ char a <* char b <* empty)
                        (Right <$> empty)
                  s = a : as
              grs  p s (`shouldFailWith` err posI 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 Char Void) Char)
                  p = withRecovery (return . Left) empty
              grs  p s (`shouldParse` Left (err posI 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 Char Void) String)
                  p = withRecovery (return . Left)
                        (Right <$> many (char a) <* empty) <* empty
                  s = b : as
              grs  p s (`shouldFailWith` err posI (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 Char Void) Char)
                  p = withRecovery (\e -> Left e <$ empty) empty
              grs  p s (`shouldFailWith` err posI mempty)
              grs' p s (`failsLeaving` s)
      it "works in complex situations too" $
        property $ \a' b' c' -> do
          let p :: MonadParsec Void String m => m (Either (ParseError Char 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
              [a,b,c] = getNonNegative <$> [a',b',c']
              f = flip shouldFailWith
              z = flip shouldParse
              r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a'))
                | a == 0 && b == 0 && c >  3 = f (err posI (utok 'c' <> etok 'a'))
                | a == 0 && b == 0           = f (err posI (utok 'c' <> etok 'a'))
                | a == 0 && b >  3           = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'c'))
                | a == 0 &&           c == 0 = f (err (posN b s) (ueof <> etok 'c'))
                | a == 0 &&           c >  3 = f (err (posN (b + 3) s) (utok 'c' <> eeof))
                | a == 0                     = z (Left (err posI (utok 'b' <> etok 'a')))
                | a >  3                     = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))
                |           b == 0 && c == 0 = f (err (posN a s) (ueof <> etok 'c' <> ma))
                |           b == 0 && c >  3 = f (err (posN (a + 3) s) (utok 'c' <> eeof))
                |           b == 0           = z (Right s)
                | otherwise                  = f (err (posN a s) (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 Char 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 Char Void) Char)
                p = observing (char a *> char b)
                s = a : c : as
            grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (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 Char Void) Char)
                p = observing (char a *> char b) *> empty
                s = a : c : as
            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) 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 Char 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 Char Void) ())
                p = observing empty
            grs  p s (`shouldParse` Left (err posI 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 Char Void) Char)
                p = observing (char a) <* empty
                s = b : as
            grs  p s (`shouldFailWith` err posI (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 posI (utok a <> eeof))
            grs' eof s (`failsLeaving` s)

    describe "token" $ do
      let f x = Tokens (nes x)
          testChar a x =
            if x == a
              then Right x
              else Left (pure (f x), E.singleton (f a))
      context "when supplied predicate is satisfied" $
        it "succeeds" $
          property $ \a as mtok -> do
            let p :: MonadParsec Void String m => m Char
                p = token (testChar a) mtok
                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 mtok -> a /= b ==> do
            let p :: MonadParsec Void String m => m Char
                p = token (testChar b) mtok
                s = a : as
                us = pure (Tokens $ nes a)
                ps = E.singleton (Tokens $ nes b)
            grs  p s (`shouldFailWith` TrivialError posI us ps)
            grs' p s (`failsLeaving` s)
      context "when stream is empty" $
        it "signals correct parse error" $
          property $ \a mtok -> do
            let p :: MonadParsec Void String m => m Char
                p = token (testChar a) mtok
                us = pure EndOfInput
                ps = maybe E.empty (E.singleton . Tokens . nes) mtok
            grs p "" (`shouldFailWith` TrivialError posI 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 posI (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 (posN 3 s) (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 (posN 6 s) (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 (posN 3 s) 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 posI (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 posI (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 posI 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 (posN 3 s) (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 (posN 6 s) (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 (posN 3 s) 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" $ 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 posI (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 posI ueof
                grs  p "" (`shouldFailWith` pe)
        context "when stream has not enough tokens" $
            it "signals correct parse error" $
              property $ \(Positive n) s -> length s < n && not (null s) ==> do
                let p :: MonadParsec Void String m => m String
                    p = takeP (Just "foo") n
                    pe = err (posN n s) (ueof <> elabel "foo")
                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 (posN n s) mempty
            grs  p s (`shouldFailWith` pe)
            grs' p s (`failsLeaving` drop n s)

  describe "derivatives from primitive combinators" $ do

    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 posI (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 posI xs
          runParser' p st `failsLeaving` stateInput st

    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 "region" $ do
      context "when inner parser succeeds" $
        it "has no effect" $
          property $ \st e n -> do
            let p :: Parser Int
                p = region (const e) (pure n)
            runParser' p st `shouldBe` (st, Right (n :: Int))
      context "when inner parser fails" $
        it "the given function is used on the parse error" $
          property $ \st' e pos' -> do
            let p :: Parsec Int String Int
                p = region f $
                  case e of
                    TrivialError _ us ps -> failure us ps
                    FancyError   _ xs    -> fancyFailure   xs
                f (TrivialError pos us ps) = FancyError
                  (max pos pos')
                  (E.singleton . ErrorCustom $ maybe 0 (const 1) us + E.size ps)
                f (FancyError pos xs) = FancyError
                  (max pos pos')
                  (E.singleton . ErrorCustom $ E.size xs)
                r = FancyError
                  (max (errorPos e) pos')
                  (E.singleton . ErrorCustom $
                    case e of
                      TrivialError _ us ps -> maybe 0 (const 1) us + E.size ps
                      FancyError   _ xs    -> E.size xs )
                finalPos = max (errorPos e) pos'
                st = st' { statePos = errorPos e }
            runParser' p st `shouldBe` (st { statePos = finalPos }, Left r)

    describe "takeRest" $
      it "returns rest of the input" $
        property $ \st@State {..} -> do
          let p :: Parser String
              p = takeRest
              (pos:|z) = statePos
              st' = st
                { stateInput = []
                , statePos   = advanceN
                    (Proxy :: Proxy String)
                    stateTabWidth
                    pos
                    stateInput :| z
                , stateTokensProcessed =
                    stateTokensProcessed + length stateInput }
          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 posI 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 posI 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 "setPosition and getPosition" $
      it "sets position and gets it back" $
        property $ \st pos -> do
          let p :: Parser SourcePos
              p = setPosition pos >> getPosition
              f (State s (_:|xs) tp w) y = State s (y:|xs) tp w
          runParser' p st `shouldBe` (f st pos, Right pos)

    describe "pushPosition" $
      it "adds a layer to position stack and parser continues on that level" $
        property $ \st pos ->  do
          let p :: Parser ()
              p = pushPosition pos
          fst (runParser' p st) `shouldBe`
            st { statePos = NE.cons pos (statePos st) }

    describe "popPosition" $
      it "removes a layer from position stack" $
        property $ \st -> do
          let p :: Parser ()
              p = popPosition
              pos = statePos st
          fst (runParser' p st) `shouldBe`
            st { statePos = fromMaybe pos (snd (NE.uncons pos)) }

    describe "setTokensProcessed and getTokensProcessed" $
      it "sets number of processed toknes and gets it back" $
        property $ \tp -> do
          let p = setTokensProcessed tp >> getTokensProcessed
          prs p "" `shouldParse` tp

    describe "setTabWidth and getTabWidth" $
      it "sets tab width and gets it back" $
        property $ \w -> do
          let p = setTabWidth w >> getTabWidth
          prs p "" `shouldParse` w

    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)
              p = do
                st <- getParserState
                guard (st == State s posI 0 defaultTabWidth)
                setParserState s1
                updateParserState (f s2)
                liftM2 const getParserState (setInput "")
              f (State s1' pos tp w) (State s2' _ _ _) = State (max s1' s2') pos tp w
              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 (posN (1 :: Int) s) (ueof <> etok ch1 <> etok ch2)

    describe "notFollowedBy" $
      it "generally works" $
        property $ \a' b' c' -> do
          let p = many (char =<< ask) <* notFollowedBy eof <* many anyChar
              [a,b,c] = getNonNegative <$> [a',b',c']
              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 (posN a s) (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 (anyChar <* 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 (anyChar <* 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 posI 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 posI mempty), s0, mempty :: [Int])

  describe "dbg" $ do
    -- NOTE We don't test properties here to avoid flood of debugging output
    -- when the test runs.
    context "when inner parser succeeds consuming input" $ do
      it "has no effect on how parser works" $ do
        let p = dbg "char" (char 'a')
            s = "ab"
        prs  p s `shouldParse` 'a'
        prs' p s `succeedsLeaving` "b"
      it "its hints are preserved" $ do
        let p = dbg "many chars" (many (char 'a')) <* empty
            s = "abcd"
        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (etok 'a')
        prs' p s `failsLeaving` "bcd"
    context "when inner parser fails consuming input" $
      it "has no effect on how parser works" $ do
        let p = dbg "chars" (char 'a' *> char 'c')
            s = "abc"
        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok 'b' <> etok 'c')
        prs' p s `failsLeaving` "bc"
    context "when inner parser succeeds without consuming" $ do
      it "has no effect on how parser works" $ do
        let p = dbg "return" (return 'a')
            s = "abc"
        prs  p s `shouldParse` 'a'
        prs' p s `succeedsLeaving` s
      it "its hints are preserved" $ do
        let p = dbg "many chars" (many (char 'a')) <* empty
            s = "bcd"
        prs  p s `shouldFailWith` err posI (etok 'a')
        prs' p s `failsLeaving` "bcd"
    context "when inner parser fails without consuming" $
      it "has no effect on how parser works" $ do
        let p = dbg "empty" (void empty)
            s = "abc"
        prs  p s `shouldFailWith` err posI mempty
        prs' p s `failsLeaving` s

----------------------------------------------------------------------------
-- Helpers

-- | This data type represents tokens in custom input stream.

data Span = Span
  { spanStart :: SourcePos
  , spanEnd   :: SourcePos
  , spanBody  :: NonEmpty Char
  } deriving (Eq, Ord, Show)

instance Stream [Span] where
  type Token [Span] = Span
  type Tokens [Span] = [Span]
  tokenToChunk Proxy = pure
  tokensToChunk Proxy = id
  chunkToTokens Proxy = id
  chunkLength Proxy = length
  chunkEmpty Proxy = null
  positionAt1 Proxy _ (Span start _ _) = start
  positionAtN Proxy pos [] = pos
  positionAtN Proxy _ (Span start _ _:_) = start
  advance1 Proxy _ _ (Span _ end _) = end
  advanceN Proxy _ pos [] = pos
  advanceN Proxy _ _ ts =
    let Span _ end _ = last ts in end
  take1_ [] = Nothing
  take1_ (t:ts) = Just (t, ts)
  takeN_ n s
    | n <= 0   = Just ([], s)
    | null s   = Nothing
    | otherwise = Just (splitAt n s)
  takeWhile_ = DL.span

instance Arbitrary Span where
  arbitrary = do
    start <- arbitrary
    end   <- arbitrary `suchThat` (> start)
    Span start end <$>
      (NE.fromList . getNonEmpty <$> arbitrary)

instance ShowToken Span where
  showTokens ts = concat (NE.toList . spanBody <$> ts)

instance ShowErrorComponent Int where
  showErrorComponent = show

type CustomParser = Parsec Void [Span]

pSpan :: Span -> CustomParser Span
pSpan span = token testToken (Just span)
  where
    f = Tokens . nes
    testToken x =
      if spanBody x == spanBody span
        then Right span
        else Left (pure (f x), E.singleton (f span))

incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])
incCoincidence st ts = do
  n <- getSmall <$> arbitrary
  let (pre, post) = splitAt n (stateInput st)
      pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts
  return st { stateInput = pre' ++ post }

emulateStrParsing
  :: State String
  -> String
  -> (State String, Either (ParseError Char Void) String)
emulateStrParsing st@(State i (pos:|z) tp w) s =
  if s == take l i
    then ( State (drop l i) (updatePosString w pos s :| z) (tp + fromIntegral l) w
         , Right s )
    else ( st
         , Left $ err (pos:|z) (etoks s <> utoks (take l i)) )
  where
    l = length s

eqParser :: (Eq a, Eq (Token i))
  => Parsec Void i a
  -> Parsec Void i a
  -> i -> Bool
eqParser p1 p2 i = runParser p1 "" i == runParser p2 "" i