megaparsec-tests 9.8.1 → 9.8.2
raw patch · 9 files changed
+357/−149 lines, 9 filesdep ~megaparsecPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: megaparsec
API changes (from Hackage documentation)
- Test.Hspec.Megaparsec.AdHoc: instance Test.QuickCheck.Arbitrary.Arbitrary GHC.Base.Void
+ Test.Hspec.Megaparsec.AdHoc: instance Test.QuickCheck.Arbitrary.Arbitrary GHC.Internal.Base.Void
Files
- megaparsec-tests.cabal +5/−5
- tests/Text/Megaparsec/Byte/LexerSpec.hs +24/−24
- tests/Text/Megaparsec/ByteSpec.hs +27/−27
- tests/Text/Megaparsec/Char/LexerSpec.hs +27/−27
- tests/Text/Megaparsec/CharSpec.hs +30/−30
- tests/Text/Megaparsec/ErrorSpec.hs +22/−2
- tests/Text/Megaparsec/StreamSpec.hs +50/−15
- tests/Text/Megaparsec/UnicodeSpec.hs +88/−4
- tests/Text/MegaparsecSpec.hs +84/−15
megaparsec-tests.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: megaparsec-tests-version: 9.8.1+version: 9.8.2 license: BSD-2-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com>@@ -32,7 +32,7 @@ containers >=0.5 && <0.9, hspec >=2 && <3, hspec-megaparsec >=2 && <3,- megaparsec ==9.8.1,+ megaparsec ==9.8.2, mtl >=2.2.2 && <3, text >=0.2 && <2.2, transformers >=0.4 && <0.7@@ -40,7 +40,7 @@ if flag(dev) ghc-options: -Wall -Werror -Wredundant-constraints -Wpartial-fields- -Wunused-packages+ -Wunused-packages -haddock -Winvalid-haddock else ghc-options: -O2 -Wall@@ -72,7 +72,7 @@ containers >=0.5 && <0.9, hspec >=2 && <3, hspec-megaparsec >=2 && <3,- megaparsec ==9.8.1,+ megaparsec ==9.8.2, megaparsec-tests, mtl >=2.2.2 && <3, scientific >=0.3.1 && <0.4,@@ -83,7 +83,7 @@ if flag(dev) ghc-options: -Wall -Werror -Wredundant-constraints -Wpartial-fields- -Wunused-packages+ -Wunused-packages -haddock -Winvalid-haddock else ghc-options: -O2 -Wall
tests/Text/Megaparsec/Byte/LexerSpec.hs view
@@ -78,10 +78,10 @@ let p = decimal :: Parser Integer s = B.pack (a : as) prs p s `shouldFailWith` err 0 (utok a <> elabel "integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (decimal :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (decimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "integer") describe "binary" $ do context "when stream begins with binary digits" $@@ -100,10 +100,10 @@ s = B.pack (a : as) prs p s `shouldFailWith` err 0 (utok a <> elabel "binary integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (binary :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "binary integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (binary :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "binary integer") describe "octal" $ do context "when stream begins with octal digits" $@@ -122,10 +122,10 @@ s = B.pack (a : as) prs p s `shouldFailWith` err 0 (utok a <> elabel "octal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (octal :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "octal integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (octal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "octal integer") describe "hexadecimal" $ do context "when stream begins with hexadecimal digits" $@@ -152,10 +152,10 @@ s = B.pack (a : as) prs p s `shouldFailWith` err 0 (utok a <> elabel "hexadecimal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (hexadecimal :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "hexadecimal integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (hexadecimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "hexadecimal integer") describe "scientific" $ do context "when stream begins with a number" $@@ -196,10 +196,10 @@ s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!" prs p s `shouldParse` fromFloatDigits n prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (scientific :: Parser Scientific) ""- `shouldFailWith` err 0 (ueof <> elabel "digit")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (scientific :: Parser Scientific) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") describe "float" $ do context "when stream begins with a float" $@@ -237,10 +237,10 @@ s = B8.pack $ showFFloatAlt Nothing (n :: Double) "err!" prs p s `shouldParse` n prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (float :: Parser Double) ""- `shouldFailWith` err 0 (ueof <> elabel "digit")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (float :: Parser Double) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") context "when there is float with just exponent" $ it "parses it all right" $ do
tests/Text/Megaparsec/ByteSpec.hs view
@@ -46,12 +46,12 @@ 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 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 ->@@ -61,12 +61,12 @@ `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")+ 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)@@ -103,9 +103,9 @@ 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")+ 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" $@@ -123,9 +123,9 @@ 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")+ 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@@ -194,9 +194,9 @@ 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)+ 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@@ -214,9 +214,9 @@ 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)+ 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@@ -227,9 +227,9 @@ 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)+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs p "" `shouldFailWith` err 0 (ueof <> elabel name) prs :: -- | Parser to run
tests/Text/Megaparsec/Char/LexerSpec.hs view
@@ -288,9 +288,9 @@ let s = "\\" prs p s `shouldFailWith` err 0 (utok '\\' <> elabel "literal character") prs' p s `failsLeaving` s- context "when stream is empty" $- it "signals correct parse error" $- prs p "" `shouldFailWith` err 0 (ueof <> elabel "literal character")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs p "" `shouldFailWith` err 0 (ueof <> elabel "literal character") context "when given a long escape sequence" $ it "parses it correctly" $ property $ \s' -> do@@ -321,10 +321,10 @@ let p = decimal :: Parser Integer s = a : as prs p s `shouldFailWith` err 0 (utok a <> elabel "integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (decimal :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (decimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "integer") describe "binary" $ do context "when stream begins with binary digits" $@@ -343,10 +343,10 @@ s = a : as prs p s `shouldFailWith` err 0 (utok a <> elabel "binary integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (binary :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "binary integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (binary :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "binary integer") describe "octal" $ do context "when stream begins with octal digits" $@@ -365,10 +365,10 @@ s = a : as prs p s `shouldFailWith` err 0 (utok a <> elabel "octal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (octal :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "octal integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (octal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "octal integer") describe "hexadecimal" $ do context "when stream begins with hexadecimal digits" $@@ -387,10 +387,10 @@ s = a : as prs p s `shouldFailWith` err 0 (utok a <> elabel "hexadecimal integer")- context "when stream is empty" $- it "signals correct parse error" $- prs (hexadecimal :: Parser Integer) ""- `shouldFailWith` err 0 (ueof <> elabel "hexadecimal integer")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (hexadecimal :: Parser Integer) ""+ `shouldFailWith` err 0 (ueof <> elabel "hexadecimal integer") describe "scientific" $ do context "when stream begins with a number" $@@ -430,10 +430,10 @@ s = showFFloatAlt Nothing (n :: Double) "err!" prs p s `shouldParse` fromFloatDigits n prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (scientific :: Parser Scientific) ""- `shouldFailWith` err 0 (ueof <> elabel "digit")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (scientific :: Parser Scientific) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") describe "float" $ do context "when stream begins with a float" $@@ -471,10 +471,10 @@ s = showFFloatAlt Nothing (n :: Double) "err!" prs p s `shouldParse` n prs' p s `succeedsLeaving` "err!"- context "when stream is empty" $- it "signals correct parse error" $- prs (float :: Parser Double) ""- `shouldFailWith` err 0 (ueof <> elabel "digit")+ context "when stream is empty"+ $ it "signals correct parse error"+ $ prs (float :: Parser Double) ""+ `shouldFailWith` err 0 (ueof <> elabel "digit") context "when there is float with just exponent" $ it "parses it all right" $ do
tests/Text/Megaparsec/CharSpec.hs view
@@ -38,12 +38,12 @@ 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 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 ->@@ -53,12 +53,12 @@ `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")+ 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)@@ -95,9 +95,9 @@ 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")+ 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" $@@ -115,9 +115,9 @@ 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")+ 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@@ -181,9 +181,9 @@ 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")+ 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" $@@ -318,9 +318,9 @@ 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)+ 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@@ -338,9 +338,9 @@ 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)+ 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@@ -351,9 +351,9 @@ 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)+ 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
tests/Text/Megaparsec/ErrorSpec.hs view
@@ -3,6 +3,7 @@ module Text.Megaparsec.ErrorSpec (spec) where import Control.Exception (Exception (..))+import qualified Data.ByteString as B import Data.Functor.Identity import Data.List (isInfixOf, isSuffixOf, sort) import Data.List.NonEmpty (NonEmpty (..))@@ -106,6 +107,21 @@ pe = err 4 (utok 'd' <> etok 'x') :: PE mkBundlePE s pe `shouldBe` "1:4:\n |\n1 | abc\SOHdef\SOHghi\n | ^\nunexpected 'd'\nexpecting 'x'\n"+ it "expands tabs after wide characters to the same width as the column count" $ do+ let s = "日本\tx" :: String+ pe = err 3 (utok 'x' <> etok 'd') :: PE+ mkBundlePE s pe+ `shouldBe` "1:9:\n |\n1 | 日本 x\n | ^\nunexpected 'x'\nexpecting 'd'\n"+ it "expands tabs after zero-width characters to the same width as the column count" $ do+ let s = "\SOH\SOH\tx" :: String+ pe = err 3 (utok 'x' <> etok 'd') :: PE+ mkBundlePE s pe+ `shouldBe` "1:9:\n |\n1 | \SOH\SOH x\n | ^\nunexpected 'x'\nexpecting 'd'\n"+ it "shows position marker for byte streams with zero-width bytes" $ do+ let s = B.pack (replicate 8 0xad ++ [0x78]) -- soft hyphens and 'x'+ pe = err 8 (utok 0x78 <> etok 0x64) :: ParseError B.ByteString Void+ mkBundlePE s pe+ `shouldBe` "1:1:\n |\n1 | \173\173\173\173\173\173\173\173x\n | ^\nunexpected 'x'\nexpecting 'd'\n" it "shows position marker for newline errors at end of line" $ do let s = "abc\n" :: String pe = err 3 (utok '\n' <> elabel "end of line") :: PE@@ -142,6 +158,10 @@ pe = err 3 (ueof <> etok 'x') :: PE mkBundlePE s pe `shouldBe` "1:1:\n |\n1 | <empty line>\n | ^\nunexpected end of input\nexpecting 'x'\n"+ -- In these cases the offending line does not include the part of the+ -- line that precedes the starting column, so it is shorter than the+ -- reported column suggests and the marker ends up past its end. That is+ -- still more helpful than omitting the marker. context "starting column in bundle is greater than 1" $ do context "and less than parse error column" $ it "is rendered correctly" $@@ -161,7 +181,7 @@ } } errorBundlePretty bundle- `shouldBe` "1:6:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n"+ `shouldBe` "1:6:\n |\n1 | foo\n | ^\nunexpected 'o'\nexpecting 'x'\n" context "and greater than parse error column" $ it "is rendered correctly" $ do@@ -180,7 +200,7 @@ } } errorBundlePretty bundle- `shouldBe` "1:10:\n |\n1 | foo\n | \nunexpected 'o'\nexpecting 'x'\n"+ `shouldBe` "1:10:\n |\n1 | foo\n | ^\nunexpected 'o'\nexpecting 'x'\n" it "takes tab width into account correctly" $ property $ \w' i' -> do let w = unPos w'
tests/Text/Megaparsec/StreamSpec.hs view
@@ -20,6 +20,7 @@ import Test.Hspec.Megaparsec.AdHoc import Test.QuickCheck import Text.Megaparsec+import qualified Text.Megaparsec.Unicode as Unicode spec :: Spec spec = do@@ -45,9 +46,9 @@ property $ \chk -> chunkEmpty sproxy chk === (chunkLength sproxy chk <= 0) describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: String) === Nothing+ context "when input in empty"+ $ it "returns Nothing"+ $ take1_ ("" :: String) === Nothing context "when input is not empty" $ it "unconses a token" $ property $ \s ->@@ -98,9 +99,9 @@ property $ \chk -> chunkEmpty bproxy chk === (chunkLength bproxy chk <= 0) describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: B.ByteString) === Nothing+ context "when input in empty"+ $ it "returns Nothing"+ $ take1_ ("" :: B.ByteString) === Nothing context "when input is not empty" $ it "unconses a token" $ property $ \s ->@@ -129,6 +130,20 @@ describeShowTokens bproxy quotedWordGen describeReachOffset bproxy describeReachOffsetNoLine bproxy+ describe "column calculation" $+ it "advances columns by the display width of the byte as Latin-1" $+ forM_ (filter (`notElem` [0x09, 0x0a]) [minBound .. maxBound]) $ \w -> do+ let pst =+ PosState+ { pstateInput = B.singleton w,+ pstateOffset = 0,+ pstateSourcePos = initialPos "",+ pstateTabWidth = defaultTabWidth,+ pstateLinePrefix = ""+ }+ c = sourceColumn (pstateSourcePos (reachOffsetNoLine 1 pst))+ (w, unPos c)+ `shouldBe` (w, 1 + Unicode.charLength (chr (fromIntegral w))) describe "Lazy ByteString instance of Stream" $ do describe "tokenToChunk" $@@ -152,9 +167,9 @@ property $ \chk -> chunkEmpty blproxy chk === (chunkLength blproxy chk <= 0) describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: BL.ByteString) === Nothing+ context "when input in empty"+ $ it "returns Nothing"+ $ take1_ ("" :: BL.ByteString) === Nothing context "when input is not empty" $ it "unconses a token" $ property $ \s ->@@ -206,9 +221,9 @@ property $ \chk -> chunkEmpty tproxy chk === (chunkLength tproxy chk <= 0) describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: T.Text) === Nothing+ context "when input in empty"+ $ it "returns Nothing"+ $ take1_ ("" :: T.Text) === Nothing context "when input is not empty" $ it "unconses a token" $ property $ \s ->@@ -259,9 +274,9 @@ property $ \chk -> chunkEmpty tlproxy chk === (chunkLength tlproxy chk <= 0) describe "take1_" $ do- context "when input in empty" $- it "returns Nothing" $- take1_ ("" :: TL.Text) === Nothing+ context "when input in empty"+ $ it "returns Nothing"+ $ take1_ ("" :: TL.Text) === Nothing context "when input is not empty" $ it "unconses a token" $ property $ \s ->@@ -468,6 +483,16 @@ SourcePos n l c = pstateSourcePos pst w = pstateTabWidth pst r `shouldBe` SourcePos n l (toNextTab w c)+ it "returns correct SourcePos (zero-width)" $+ property $ \pst' -> do+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\173" :: s -- soft hyphen+ }+ o = pstateOffset pst + 1+ r = pstateSourcePos . snd $ reachOffset o pst+ SourcePos n l c = pstateSourcePos pst+ r `shouldBe` SourcePos n l c it "returns correct SourcePos (other)" $ property $ \pst' -> do let pst =@@ -563,6 +588,16 @@ SourcePos n l c = pstateSourcePos pst w = pstateTabWidth pst r `shouldBe` SourcePos n l (toNextTab w c)+ it "returns correct SourcePos (zero-width)" $+ property $ \pst' -> do+ let pst =+ (pst' :: PosState s)+ { pstateInput = "\173" :: s -- soft hyphen+ }+ o = pstateOffset pst + 1+ r = pstateSourcePos (reachOffsetNoLine o pst)+ SourcePos n l c = pstateSourcePos pst+ r `shouldBe` SourcePos n l c it "returns correct SourcePos (other)" $ property $ \pst' -> do let pst =
tests/Text/Megaparsec/UnicodeSpec.hs view
@@ -1,20 +1,104 @@ module Text.Megaparsec.UnicodeSpec (spec) where +import Control.Monad (forM_) import Test.Hspec import qualified Text.Megaparsec.Unicode as Unicode spec :: Spec spec = do- describe "stringLength" $+ describe "stringLength" $ do it "computes correct length in the presence of wide chars" $ Unicode.stringLength "123 구구 이면" `shouldBe` 13+ it "computes correct length in the presence of zero-width chars" $+ -- A letter, a combining acute accent that occupies no cell of its+ -- own, and a wide ideograph.+ Unicode.stringLength "e\769日" `shouldBe` 3 describe "charLength" $ do- it "returns 1 for non-wide chars" $- Unicode.charLength 'a' `shouldBe` 1+ it "returns 1 for ordinary chars" $+ expectLengths 1 narrowChars it "returns 2 for wide chars" $- Unicode.charLength '구' `shouldBe` 2+ expectLengths 2 wideChars+ it "returns 0 for zero-width chars" $+ expectLengths 0 zeroWidthChars+ it "agrees with isWideChar and isZeroWidthChar for every code point" $+ -- Among other things this pins down the shortcut that both functions+ -- take for the characters below the top of the Latin-1 range.+ let inconsistent ch =+ let n = Unicode.charLength ch+ in n `notElem` [0, 1, 2]+ || Unicode.isWideChar ch /= (n == 2)+ || Unicode.isZeroWidthChar ch /= (n == 0)+ in take 5 (filter inconsistent [minBound .. maxBound]) `shouldBe` [] describe "isWideChar" $ do it "returns False for non-wide chars" $ Unicode.isWideChar 'a' `shouldBe` False it "returns True for wide chars" $ Unicode.isWideChar '구' `shouldBe` True+ it "returns False for wide chars that combine with their neighbour" $+ -- U+302A is Wide by East Asian Width but it is a non-spacing mark, so+ -- it does not occupy two columns of its own.+ Unicode.isWideChar '\12330' `shouldBe` False+ describe "isZeroWidthChar" $ do+ it "returns False for ordinary chars" $+ Unicode.isZeroWidthChar 'a' `shouldBe` False+ it "returns True for control chars" $+ Unicode.isZeroWidthChar '\SOH' `shouldBe` True+ it "returns True for combining marks" $+ Unicode.isZeroWidthChar '\769' `shouldBe` True++-- | Check that every character in the collection has the given length,+-- naming the offending one if it does not.+expectLengths :: Int -> [(String, Char)] -> Expectation+expectLengths n cs =+ forM_ cs $ \(name, ch) ->+ (name, Unicode.charLength ch) `shouldBe` (name, n)++-- | Characters that occupy a single column.+narrowChars :: [(String, Char)]+narrowChars =+ [ ("U+0061 latin small letter a", 'a'),+ ("U+00E9 latin small letter e with acute", '\233'),+ ("U+0416 cyrillic capital letter zhe", '\1046'),+ ("U+05D0 hebrew letter alef", '\1488'),+ ("U+0E01 thai character ko kai", '\3585'),+ ("U+2192 rightwards arrow", '\8594')+ ]++-- | Characters that occupy two columns. The comments give the version of+-- the Unicode standard that assigned them, which is what makes them a+-- reasonable regression test for stale character width data.+wideChars :: [(String, Char)]+wideChars =+ [ ("U+4E00 cjk unified ideograph (1.1)", '\19968'),+ ("U+9FFF cjk unified ideograph (14.0)", '\40959'),+ ("U+4DBF cjk unified ideograph (13.0)", '\19903'),+ ("U+31BF bopomofo letter (14.0)", '\12735'),+ ("U+AC00 hangul syllable ga", '\44032'),+ ("U+FF21 fullwidth latin capital letter a", '\65313'),+ ("U+1F600 grinning face (6.1)", '\128512'),+ ("U+1F6DD playground slide (14.0)", '\128733'),+ ("U+1FAE0 melting face (14.0)", '\129760'),+ ("U+30000 cjk unified ideograph extension g (13.0)", '\196608'),+ ("U+31350 cjk unified ideograph extension h (15.0)", '\201552')+ ]++-- | Characters that occupy no columns at all.+zeroWidthChars :: [(String, Char)]+zeroWidthChars =+ [ ("U+0001 start of heading", '\SOH'),+ ("U+00AD soft hyphen", '\173'),+ ("U+0301 combining acute accent", '\769'),+ ("U+0651 arabic shadda", '\1617'),+ ("U+093C devanagari sign nukta", '\2364'),+ ("U+0BCD tamil sign virama", '\3021'),+ ("U+0E31 thai character mai han akat", '\3633'),+ ("U+1AB0 combining doubled circumflex accent", '\6832'),+ ("U+1DC0 combining dotted grave accent", '\7616'),+ ("U+200D zero width joiner", '\8205'),+ ("U+2060 word joiner", '\8288'),+ ("U+20E3 combining enclosing keycap", '\8419'),+ ("U+FE0F variation selector-16", '\65039'),+ ("U+FEFF zero width no-break space", '\65279'),+ ("U+11FF hangul jongseong ssangnieun", '\4607'),+ ("U+E0101 variation selector-18", '\917761')+ ]
tests/Text/MegaparsecSpec.hs view
@@ -222,12 +222,35 @@ pRightAssociative = (a <|> (b <|> c)) >> char 'd' e = err 0 (utok 'a' <> etok 'd' <> etok 'b') s = "aaa"- context "left associative" $- it "fails with the right error" $- prs pLeftAssociative s `shouldFailWith` e- context "right associative" $- it "fails with the right error" $- prs pRightAssociative s `shouldFailWith` e+ context "left associative"+ $ it "fails with the right error"+ $ prs pLeftAssociative s `shouldFailWith` e+ context "right associative"+ $ it "fails with the right error"+ $ prs pRightAssociative s `shouldFailWith` e+ context "when a branch fails ahead of the alternation due to try" $ do+ context "when the other branch fails where the alternation started" $+ it "reports the error there keeping its expected items" $ do+ let p = try (char 'a' >> char 'b') <|> char 'c'+ prs p "ad" `shouldFailWith` err 0 (utok 'a' <> etok 'c')+ prs' p "ad" `failsLeaving` "ad"+ context "when both branches fail ahead at the same offset" $+ it "prefers the longest match" $ do+ let p = try (char 'a' >> char 'b') <|> try (char 'a' >> char 'c')+ prs p "ad" `shouldFailWith` err 1 (utok 'd' <> etok 'b' <> etok 'c')+ context "when both branches fail ahead at different offsets" $+ it "prefers the longest match" $ do+ let p =+ try (char 'a' >> char 'b')+ <|> try (char 'a' >> char 'd' >> char 'e')+ prs p "adx" `shouldFailWith` err 2 (utok 'x' <> etok 'e')+ it "is associative no matter where the branches fail" $+ property $ \b1 b2 b3 -> do+ let p = altBranch b1+ q = altBranch b2+ r = altBranch b3+ prs ((p <|> q) <|> r) altBranchInput+ `shouldBe` prs (p <|> (q <|> r)) altBranchInput 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"@@ -922,9 +945,9 @@ 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 empty"+ $ it "succeeds"+ $ grs eof "" (`shouldParse` ()) context "when input stream is not empty" $ it "signals correct error message" $ property $ \a as -> do@@ -1106,6 +1129,11 @@ p = takeP Nothing 0 grs p s (`shouldParse` "") grs' p s (`succeedsLeaving` s)+ it "does not consume input, so the next alternative is tried" $+ property $ \s -> do+ let p :: (MonadParsec Void String m) => m String+ p = (takeP Nothing 0 *> empty) <|> pure "alt"+ grs p s (`shouldParse` "alt") context "when taking <0 tokens" $ do context "when stream is empty" $ it "succeeds returning zero-length chunk" $@@ -1121,6 +1149,11 @@ p = takeP Nothing n grs p s (`shouldParse` "") grs' p s (`succeedsLeaving` s)+ it "does not consume input, so the next alternative is tried" $+ property $ \(Negative n) s -> do+ let p :: (MonadParsec Void String m) => m String+ p = (takeP Nothing n *> empty) <|> pure "alt"+ grs p s (`shouldParse` "alt") context "when taking >0 tokens" $ do context "when stream is empty" $ do context "with label" $@@ -1157,6 +1190,12 @@ (s0, s1) = splitAt n s grs p s (`shouldParse` s0) grs' p s (`succeedsLeaving` s1)+ it "consumes input, so the next alternative is not tried" $+ property $ \(Positive n) s ->+ length s >= n ==> do+ let p :: (MonadParsec Void String m) => m String+ p = (takeP Nothing n *> empty) <|> pure "alt"+ grs p s (`shouldFailWith` err n mempty) context "when failing right after takeP (testing hints)" $ it "there are no hints to influence the parse error" $ property $ \(Positive n) s ->@@ -1287,9 +1326,9 @@ let s' = ch : s grs p s' (`shouldParse` ch) grs' p s' (`succeedsLeaving` s)- context "when stream is empty" $- it "signals correct parse error" $- grs p "" (`shouldFailWith` err 0 ueof)+ context "when stream is empty"+ $ it "signals correct parse error"+ $ grs p "" (`shouldFailWith` err 0 ueof) describe "anySingleBut" $ do context "when stream begins with the character specified as argument" $@@ -1308,9 +1347,9 @@ p = anySingleBut ch grs p s (`shouldParse` head s) grs' p s (`succeedsLeaving` tail s)- context "when stream is empty" $- it "signals correct parse error" $- grs (anySingleBut 'a') "" (`shouldFailWith` err 0 ueof)+ context "when stream is empty"+ $ it "signals correct parse error"+ $ grs (anySingleBut 'a') "" (`shouldFailWith` err 0 ueof) describe "oneOf" $ do context "when stream begins with one of specified characters" $@@ -1839,6 +1878,36 @@ s -> Bool eqParser p1 p2 s = runParser p1 "" s == runParser p2 "" s++-- | A description of a branch of an alternation, used for testing the+-- associativity of ('<|>'). Every branch fails on 'altBranchInput', but+-- depending on the constructor it fails either exactly where the+-- alternation started or ahead of that position, which is the interesting+-- case because it can only happen due to 'try'.+data AltBranch+ = -- | Fail without consuming input+ AltAt Char+ | -- | Fail one token ahead, but backtrack+ AltAhead Char+ deriving (Eq, Show)++instance Arbitrary AltBranch where+ arbitrary = do+ f <- elements [AltAt, AltAhead]+ -- Neither 'a' nor 'd' so that the branch is guaranteed to fail on+ -- 'altBranchInput'.+ f <$> elements "bcexyz"++-- | The input on which the parsers produced by 'altBranch' are supposed to+-- be run.+altBranchInput :: String+altBranchInput = "ad"++-- | Turn an 'AltBranch' into a parser that fails on 'altBranchInput'.+altBranch :: AltBranch -> Parser Char+altBranch = \case+ AltAt c -> char c+ AltAhead c -> try (char 'a' >> char c) mkBundle :: State s e ->