megaparsec-tests-9.0.0: tests/Text/Megaparsec/ByteSpec.hs
{-# LANGUAGE CPP #-}
{-# 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
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ((<>))
#endif
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