content: {-# OPTIONS_GHC -fno-warn-orphans #-}
  
  module Text.Megaparsec.CharSpec (spec) where
  
  import Control.Monad
  import qualified Data.CaseInsensitive as CI
  import Data.Char
  import Data.List (isPrefixOf, nub, partition)
  import Test.Hspec
  import Test.Hspec.Megaparsec
  import Test.Hspec.Megaparsec.AdHoc
  import Test.QuickCheck
  import Text.Megaparsec
  import Text.Megaparsec.Char
  
  instance Arbitrary GeneralCategory where
    arbitrary = elements [minBound .. maxBound]
  
  spec :: Spec
  spec = do
    describe "newline" $
      checkStrLit "newline" "\n" (pure <$> 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 /= '\n' ==> do
              let s = ['\r', 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 '\r' <> elabel "end of line")
      context "when stream does not begin with newline or CRLF sequence" $
        it "signals correct parse error" $
          property $ \ch s ->
            (ch `notElem` "\r\n") ==> do
              let s' = ch : s
              prs eol s'
                `shouldFailWith` err
                  0
                  (utoks (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" (pure <$> tab)
  
    describe "space" $
      it "consumes space up to first non-space character" $
        property $ \s' -> do
          let (s0, s1) = 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) = 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) = partition isSpace s'
                  s = 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) = 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 (isHSpace ch) ==> do
              let (s0, s1) = partition isHSpace s'
                  s = 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) = 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 controlChar
  
    describe "spaceChar" $
      checkCharRange "white space" " \160\t\n\r\f\v" spaceChar
  
    describe "upperChar" $
      checkCharPred "uppercase letter" isUpper upperChar
  
    describe "lowerChar" $
      checkCharPred "lowercase letter" isLower lowerChar
  
    describe "letterChar" $
      checkCharPred "letter" isAlpha letterChar
  
    describe "printChar" $
      checkCharPred "printable character" isPrint printChar
  
    describe "digitChar" $
      checkCharRange "digit" ['0' .. '9'] digitChar
  
    describe "binDigitChar" $
      checkCharRange "binary digit" ['0' .. '1'] binDigitChar
  
    describe "octDigitChar" $
      checkCharRange "octal digit" ['0' .. '7'] octDigitChar
  
    describe "hexDigitChar" $
      checkCharRange "hexadecimal digit" (['0' .. '9'] ++ ['a' .. 'f'] ++ ['A' .. 'F']) hexDigitChar
  
    describe "markChar" $
      checkCharRange "mark character" "\71229\7398" markChar
  
    describe "numberChar" $
      let xs = "\185\178\179\188\189\190" ++ ['0' .. '9']
       in checkCharRange "numeric character" xs numberChar
  
    describe "punctuationChar" $
      checkCharPred "punctuation" isPunctuation punctuationChar
  
    describe "symbolChar" $
      checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar
    describe "separatorChar" $
      checkCharRange "separator" " \160" separatorChar
  
    describe "asciiChar" $
      checkCharPred "ASCII character" isAscii asciiChar
  
    describe "latin1Char" $ do
      context "when stream begins with Latin-1 character" $
        it "parses the Latin-1 character" $
          property $ \ch s ->
            isLatin1 ch ==> do
              let s' = ch : s
              prs latin1Char s' `shouldParse` ch
              prs' latin1Char s' `succeedsLeaving` s
      context "when stream does not begin with Latin-1 character" $
        it "signals correct parse error" $
          do
            prs latin1Char "б"
              `shouldFailWith` err 0 (utok 'б' <> elabel "Latin-1 character")
            prs' latin1Char "в" `failsLeaving` "в"
      context "when stream is empty" $
        it "signals correct parse error" $
          prs latin1Char "" `shouldFailWith` err 0 (ueof <> elabel "Latin-1 character")
  
    describe "charCategory" $ do
      context "when parser corresponding to general category of next char is used" $
        it "succeeds" $
          property $ \ch s -> do
            let s' = ch : s
                g = generalCategory ch
            prs (charCategory g) s' `shouldParse` ch
            prs' (charCategory g) s' `succeedsLeaving` s
      context "when parser's category does not match next character's category" $
        it "fails" $
          property $ \g ch s ->
            (generalCategory ch /= g) ==> do
              let s' = ch : s
              prs (charCategory g) s'
                `shouldFailWith` err 0 (utok ch <> elabel (categoryName g))
              prs' (charCategory g) s' `failsLeaving` s'
      context "when stream is empty" $
        it "signals correct parse error" $
          property $ \g ->
            prs (charCategory g) ""
              `shouldFailWith` err 0 (ueof <> elabel (categoryName g))
  
    describe "char" $ do
      context "when stream begins with the character specified as argument" $
        it "parses the character" $
          property $ \ch s -> do
            let s' = ch : s
            prs (char ch) s' `shouldParse` ch
            prs' (char ch) s' `succeedsLeaving` s
      context "when stream does not begin with the character specified as argument" $
        it "signals correct parse error" $
          property $ \ch ch' s ->
            ch /= ch' ==> do
              let s' = ch' : s
              prs (char ch) s' `shouldFailWith` err 0 (utok ch' <> etok ch)
              prs' (char ch) s' `failsLeaving` s'
      context "when stream is empty" $
        it "signals correct parse error" $
          property $ \ch ->
            prs (char ch) "" `shouldFailWith` err 0 (ueof <> etok ch)
  
    describe "char'" $ do
      context "when stream begins with the character specified as argument" $ do
        it "parses the character" $
          property $ \ch s -> do
            let sl = toLower ch : s
                su = toUpper ch : s
                st = toTitle ch : s
            prs (char' ch) sl `shouldParse` toLower ch
            prs (char' ch) su `shouldParse` toUpper ch
            prs (char' ch) st `shouldParse` toTitle ch
            prs' (char' ch) sl `succeedsLeaving` s
            prs' (char' ch) su `succeedsLeaving` s
        context "when the character is not upper or lower" $
          -- See https://ghc.haskell.org/trac/ghc/ticket/14589
          it "matches it against a form obtained via one of the conversion functions" $
            property $ \s -> do
              let ch = '\9438'
                  s' = '\9412' : s
              prs (char' ch) s' `shouldParse` '\9412'
              prs' (char' ch) s' `succeedsLeaving` s
      context "when stream does not begin with the character specified as argument" $ do
        it "signals correct parse error" $
          property $ \ch ch' s ->
            not (casei ch ch') ==> do
              let s' = ch' : s
                  ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch) <> etok (toTitle ch)
              prs (char' ch) s' `shouldFailWith` err 0 ms
              prs' (char' ch) s' `failsLeaving` s'
        context "when the character is not upper or lower" $
          it "lists correct options in the error message" $
            property $ \ch s ->
              not (casei '\9438' ch) ==> do
                let ms = utok ch <> etok '\9438' <> etok '\9412'
                    s' = ch : s
                prs (char' '\9438') s' `shouldFailWith` err 0 ms
      context "when stream is empty" $
        it "signals correct parse error" $
          property $ \ch -> do
            let options = etok <$> [toLower ch, toTitle ch, toUpper ch]
                ms = ueof <> mconcat (nub options)
            prs (char' ch) "" `shouldFailWith` err 0 ms
  
    describe "string" $ do
      context "when stream is prefixed with given string" $
        it "parses the string" $
          property $ \str s -> do
            let s' = str ++ s
            prs (string str) s' `shouldParse` str
            prs' (string str) 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 us = take (length str) s
              prs (string str) s `shouldFailWith` err 0 (utoks us <> etoks str)
  
    describe "string'" $ do
      context "when stream is prefixed with given string" $
        it "parses the string" $
          property $ \str s ->
            forAll (fuzzyCase str) $ \str' -> do
              let s' = str' ++ s
              -- Rare tricky cases we don't want to deal with.
              when (CI.mk str /= CI.mk str') discard
              prs (string' str) s' `shouldParse` str'
              prs' (string' str) s' `succeedsLeaving` s
      context "when stream is not prefixed with given string" $
        it "signals correct parse error" $
          property $ \str s ->
            not (str `isPrefixOfI` s) ==> do
              let us = take (length str) s
              prs (string' str) s `shouldFailWith` err 0 (utoks us <> etoks str)
  
  ----------------------------------------------------------------------------
  -- Helpers
  
  checkStrLit :: String -> String -> Parser String -> 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 /= head ts ==> do
            let s' = ch : s
                us = take (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 -> (Char -> Bool) -> Parser Char -> SpecWith ()
  checkCharPred name f p = do
    context ("when stream begins with " ++ name) $
      it ("parses the " ++ name) $
        property $ \ch s ->
          f ch ==> do
            let s' = 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' = 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 -> String -> Parser Char -> SpecWith ()
  checkCharRange name tchs p = do
    forM_ tchs $ \tch ->
      context ("when stream begins with " ++ showTokens sproxy (nes tch)) $
        it ("parses the " ++ showTokens sproxy (nes tch)) $
          property $ \s -> do
            let s' = 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)
  
  -- | Randomly change the case in the given string.
  fuzzyCase :: String -> Gen String
  fuzzyCase s = zipWith f s <$> vector (length s)
    where
      f k True = if isLower k then toUpper k else toLower k
      f k False = k
  
  -- | The 'isPrefixOf' function takes two 'String's and returns 'True' iff
  -- the first list is a prefix of the second with case-insensitive
  -- comparison.
  isPrefixOfI :: String -> String -> Bool
  isPrefixOfI [] _ = True
  isPrefixOfI _ [] = False
  isPrefixOfI (x : xs) (y : ys) = x `casei` y && isPrefixOf xs ys
  
  -- | Case-insensitive equality test for characters.
  casei :: Char -> Char -> Bool
  casei x y =
    x == toLower y
      || x == toUpper y
      || x == toTitle y
  
  -- | Is it a horizontal space character?
  isHSpace :: Char -> Bool
  isHSpace x = isSpace x && x /= '\n' && x /= '\r'
  