megaparsec-tests-8.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 Data.Char
import Data.Maybe (fromMaybe)
import Data.Void
import Data.Word (Word8)
import Test.Hspec
import Test.Hspec.Megaparsec
import Test.Hspec.Megaparsec.AdHoc hiding (prs, prs', Parser)
import Test.QuickCheck
import Text.Megaparsec
import Text.Megaparsec.Byte
import qualified Data.ByteString as B
#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 "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 "controlChar" $
checkCharPred "control character" (isControl . toChar) controlChar
describe "spaceChar" $
checkCharRange "white space" [9,10,11,12,13,32,160] spaceChar
describe "alphaNumChar" $
checkCharPred "alphanumeric character" (isAlphaNum . toChar) alphaNumChar
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 a
-- ^ Parser to run
-> ByteString
-- ^ Input for the parser
-> Either (ParseErrorBundle ByteString Void) a
-- ^ Result of parsing
prs p = parse p ""
prs'
:: Parser a
-- ^ Parser to run
-> ByteString
-- ^ Input for the parser
-> (State ByteString Void, Either (ParseErrorBundle ByteString Void) a)
-- ^ Result of parsing
prs' p s = runParser' p (initialState s)
-- | 'Word8'-specialized version of 'isSpace'.
isSpace' :: Word8 -> Bool
isSpace' x
| x >= 9 && x <= 13 = 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