content: {-# LANGUAGE OverloadedStrings #-}
  
  module Text.Megaparsec.ByteSpec (spec) where
  
  import Control.Monad
  import Data.ByteString (ByteString)
  import qualified Data.ByteString as B
  import Data.Char hiding (isSpace)
  import Data.Maybe (fromMaybe)
  import Data.Void
  import Data.Word (Word8)
  import Test.Hspec
  import Test.Hspec.Megaparsec
  import Test.Hspec.Megaparsec.AdHoc hiding (Parser, prs, prs')
  import Test.QuickCheck
  import Text.Megaparsec
  import Text.Megaparsec.Byte
  
  type Parser = Parsec Void ByteString
  
  spec :: Spec
  spec = do
    describe "newline" $
      checkStrLit "newline" "\n" (tokenToChunk bproxy <$> newline)
  
    describe "csrf" $
      checkStrLit "crlf newline" "\r\n" crlf
  
    describe "eol" $ do
      context "when stream begins with a newline" $
        it "succeeds returning the newline" $
          property $ \s -> do
            let s' = "\n" <> s
            prs eol s' `shouldParse` "\n"
            prs' eol s' `succeedsLeaving` s
      context "when stream begins with CRLF sequence" $
        it "parses the CRLF sequence" $
          property $ \s -> do
            let s' = "\r\n" <> s
            prs eol s' `shouldParse` "\r\n"
            prs' eol s' `succeedsLeaving` s
      context "when stream begins with '\\r', but it's not followed by '\\n'" $
        it "signals correct parse error" $
          property $ \ch ->
            ch /= 10 ==> do
              let s = "\r" <> B.singleton ch
              prs eol s
                `shouldFailWith` err 0 (utoks s <> elabel "end of line")
      context "when input stream is '\\r'" $
        it "signals correct parse error" $
          prs eol "\r"
            `shouldFailWith` err
              0
              (utok 13 <> elabel "end of line")
      context "when stream does not begin with newline or CRLF sequence" $
        it "signals correct parse error" $
          property $ \ch s ->
            (ch /= 13 && ch /= 10) ==> do
              let s' = B.singleton ch <> s
              prs eol s'
                `shouldFailWith` err
                  0
                  (utoks (B.take 2 s') <> elabel "end of line")
      context "when stream is empty" $
        it "signals correct parse error" $
          prs eol ""
            `shouldFailWith` err
              0
              (ueof <> elabel "end of line")
  
    describe "tab" $
      checkStrLit "tab" "\t" (tokenToChunk bproxy <$> tab)
  
    describe "space" $
      it "consumes space up to first non-space character" $
        property $ \s' -> do
          let (s0, s1) = B.partition isSpace s'
              s = s0 <> s1
          prs space s `shouldParse` ()
          prs' space s `succeedsLeaving` s1
  
    describe "hspace" $
      it "consumes space up to first non-space character" $
        property $ \s' -> do
          let (s0, s1) = B.partition isHSpace s'
              s = s0 <> s1
          prs hspace s `shouldParse` ()
          prs' hspace s `succeedsLeaving` s1
  
    describe "space1" $ do
      context "when stream does not start with a space character" $
        it "signals correct parse error" $
          property $ \ch s' ->
            not (isSpace ch) ==> do
              let (s0, s1) = B.partition isSpace s'
                  s = B.singleton ch <> s0 <> s1
              prs space1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")
              prs' space1 s `failsLeaving` s
      context "when stream starts with a space character" $
        it "consumes space up to first non-space character" $
          property $ \s' -> do
            let (s0, s1) = B.partition isSpace s'
                s = " " <> s0 <> s1
            prs space1 s `shouldParse` ()
            prs' space1 s `succeedsLeaving` s1
      context "when stream is empty" $
        it "signals correct parse error" $
          prs space1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")
  
    describe "hspace1" $ do
      context "when stream does not start with a space character" $
        it "signals correct parse error" $
          property $ \ch s' ->
            not (isSpace ch) ==> do
              let (s0, s1) = B.partition isHSpace s'
                  s = B.singleton ch <> s0 <> s1
              prs hspace1 s `shouldFailWith` err 0 (utok ch <> elabel "white space")
              prs' hspace1 s `failsLeaving` s
      context "when stream starts with a space character" $
        it "consumes space up to first non-space character" $
          property $ \s' -> do
            let (s0, s1) = B.partition isHSpace s'
                s = " " <> s0 <> s1
            prs hspace1 s `shouldParse` ()
            prs' hspace1 s `succeedsLeaving` s1
      context "when stream is empty" $
        it "signals correct parse error" $
          prs hspace1 "" `shouldFailWith` err 0 (ueof <> elabel "white space")
  
    describe "controlChar" $
      checkCharPred "control character" (isControl . toChar) controlChar
  
    describe "spaceChar" $
      checkCharRange "white space" [9, 10, 11, 12, 13, 32, 160] spaceChar
  
    describe "printChar" $
      checkCharPred "printable character" (isPrint . toChar) printChar
  
    describe "digitChar" $
      checkCharRange "digit" [48 .. 57] digitChar
  
    describe "binDigitChar" $
      checkCharRange "binary digit" [48 .. 49] binDigitChar
  
    describe "octDigitChar" $
      checkCharRange "octal digit" [48 .. 55] octDigitChar
  
    describe "hexDigitChar" $
      checkCharRange "hexadecimal digit" ([48 .. 57] ++ [97 .. 102] ++ [65 .. 70]) hexDigitChar
  
    describe "char'" $ do
      context "when stream begins with the character specified as argument" $
        it "parses the character" $
          property $ \ch s -> do
            let sl = B.cons (liftChar toLower ch) s
                su = B.cons (liftChar toUpper ch) s
                st = B.cons (liftChar toTitle ch) s
            prs (char' ch) sl `shouldParse` liftChar toLower ch
            prs (char' ch) su `shouldParse` liftChar toUpper ch
            prs (char' ch) st `shouldParse` liftChar toTitle ch
            prs' (char' ch) sl `succeedsLeaving` s
            prs' (char' ch) su `succeedsLeaving` s
            prs' (char' ch) st `succeedsLeaving` s
      context "when stream does not begin with the character specified as argument" $
        it "signals correct parse error" $
          property $ \ch ch' s ->
            not (casei ch ch') ==> do
              let s' = B.cons ch' s
                  ms = utok ch' <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)
              prs (char' ch) s' `shouldFailWith` err 0 ms
              prs' (char' ch) s' `failsLeaving` s'
      context "when stream is empty" $
        it "signals correct parse error" $
          property $ \ch -> do
            let ms = ueof <> etok (liftChar toLower ch) <> etok (liftChar toUpper ch)
            prs (char' ch) "" `shouldFailWith` err 0 ms
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  checkStrLit :: String -> ByteString -> Parser ByteString -> SpecWith ()
  checkStrLit name ts p = do
    context ("when stream begins with " ++ name) $
      it ("parses the " ++ name) $
        property $ \s -> do
          let s' = ts <> s
          prs p s' `shouldParse` ts
          prs' p s' `succeedsLeaving` s
    context ("when stream does not begin with " ++ name) $
      it "signals correct parse error" $
        property $ \ch s ->
          ch /= B.head ts ==> do
            let s' = B.cons ch s
                us = B.take (B.length ts) s'
            prs p s' `shouldFailWith` err 0 (utoks us <> etoks ts)
            prs' p s' `failsLeaving` s'
    context "when stream is empty" $
      it "signals correct parse error" $
        prs p "" `shouldFailWith` err 0 (ueof <> etoks ts)
  
  checkCharPred :: String -> (Word8 -> Bool) -> Parser Word8 -> SpecWith ()
  checkCharPred name f p = do
    context ("when stream begins with " ++ name) $
      it ("parses the " ++ name) $
        property $ \ch s ->
          f ch ==> do
            let s' = B.singleton ch <> s
            prs p s' `shouldParse` ch
            prs' p s' `succeedsLeaving` s
    context ("when stream does not begin with " ++ name) $
      it "signals correct parse error" $
        property $ \ch s ->
          not (f ch) ==> do
            let s' = B.singleton ch <> s
            prs p s' `shouldFailWith` err 0 (utok ch <> elabel name)
            prs' p s' `failsLeaving` s'
    context "when stream is empty" $
      it "signals correct parse error" $
        prs p "" `shouldFailWith` err 0 (ueof <> elabel name)
  
  checkCharRange :: String -> [Word8] -> Parser Word8 -> SpecWith ()
  checkCharRange name tchs p = do
    forM_ tchs $ \tch ->
      context ("when stream begins with " ++ showTokens bproxy (nes tch)) $
        it ("parses the " ++ showTokens bproxy (nes tch)) $
          property $ \s -> do
            let s' = B.singleton tch <> s
            prs p s' `shouldParse` tch
            prs' p s' `succeedsLeaving` s
    context "when stream is empty" $
      it "signals correct parse error" $
        prs p "" `shouldFailWith` err 0 (ueof <> elabel name)
  
  prs ::
    -- | Parser to run
    Parser a ->
    -- | Input for the parser
    ByteString ->
    -- | Result of parsing
    Either (ParseErrorBundle ByteString Void) a
  prs p = parse p ""
  
  prs' ::
    -- | Parser to run
    Parser a ->
    -- | Input for the parser
    ByteString ->
    -- | Result of parsing
    (State ByteString Void, Either (ParseErrorBundle ByteString Void) a)
  prs' p s = runParser' p (initialState s)
  
  -- | 'Word8'-specialized version of 'Data.Char.isSpace'.
  isSpace :: Word8 -> Bool
  isSpace x
    | x >= 9 && x <= 13 = True
    | x == 32 = True
    | x == 160 = True
    | otherwise = False
  
  -- | Like 'isSpace', but does not accept newlines and carriage returns.
  isHSpace :: Word8 -> Bool
  isHSpace x
    | x == 9 = True
    | x == 11 = True
    | x == 12 = True
    | x == 32 = True
    | x == 160 = True
    | otherwise = False
  
  -- | Lift char transformation to byte transformation.
  liftChar :: (Char -> Char) -> Word8 -> Word8
  liftChar f x = (fromMaybe x . fromChar . f . toChar) x
  
  -- | Compare two characters case-insensitively.
  casei :: Word8 -> Word8 -> Bool
  casei x y =
    x == liftChar toLower y
      || x == liftChar toUpper y
      || x == liftChar toTitle y
  