megaparsec 5.0.1 → 5.1.0

raw patch · 39 files changed

+4172/−3231 lines, 39 filesdep +hspecdep +hspec-expectationsdep −HUnitdep −test-frameworkdep −test-framework-hunitdep ~QuickCheckdep ~megaparsecPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, hspec-expectations

Dependencies removed: HUnit, test-framework, test-framework-hunit, test-framework-quickcheck2

Dependency ranges changed: QuickCheck, megaparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +37/−0
• README.md +16/−0
• Text/Megaparsec.hs +12/−5
• Text/Megaparsec/Char.hs +1/−1
• Text/Megaparsec/Error.hs +110/−22
• Text/Megaparsec/Expr.hs +9/−3
• Text/Megaparsec/Lexer.hs +26/−26
• Text/Megaparsec/Pos.hs +13/−1
• Text/Megaparsec/Prim.hs +192/−11
• megaparsec.cabal +32/−54
• old-tests/Bugs.hs +0/−16
• old-tests/Bugs/Bug2.hs +0/−32
• old-tests/Bugs/Bug35.hs +0/−35
• old-tests/Bugs/Bug39.hs +0/−52
• old-tests/Bugs/Bug6.hs +0/−22
• old-tests/Bugs/Bug9.hs +0/−52
• old-tests/Main.hs +0/−6
• old-tests/Util.hs +0/−12
• tests/Char.hs +0/−246
• tests/Combinator.hs +0/−233
• tests/Error.hs +0/−152
• tests/Expr.hs +0/−189
• tests/Lexer.hs +0/−402
• tests/Main.hs +0/−51
• tests/Perm.hs +0/−103
• tests/Pos.hs +0/−121
• tests/Prim.hs +0/−1017
• tests/Spec.hs +11/−0
• tests/Test/Hspec/Megaparsec.hs +376/−0
• tests/Test/Hspec/Megaparsec/AdHoc.hs +185/−0
• tests/Text/Megaparsec/CharSpec.hs +450/−0
• tests/Text/Megaparsec/CombinatorSpec.hs +256/−0
• tests/Text/Megaparsec/ErrorSpec.hs +223/−0
• tests/Text/Megaparsec/ExprSpec.hs +187/−0
• tests/Text/Megaparsec/LexerSpec.hs +486/−0
• tests/Text/Megaparsec/PermSpec.hs +125/−0
• tests/Text/Megaparsec/PosSpec.hs +127/−0
• tests/Text/Megaparsec/PrimSpec.hs +1298/−0
• tests/Util.hs +0/−367

@@ -1,3 +1,40 @@+## Megaparsec 5.1.0++* Defined `displayException` for `ParseError`, so exceptions are displayed+  in human-friendly form now. This works with GHC 7.10 and later.++* Line comments parsed by `skipLineComment` now may end at the end of input+  and do not necessarily require a newline to be parsed correctly. See #119.++* Exposed `parseErrorTextPretty` function in `Text.Megaparsec.Error` to+  allow to render `ParseError`s without stack of source positions.++* Eliminated the `old-tests` test suite — Parsec legacy. The cases that are+  not already *obviously* covered in the main test suite were included into+  it.++* Added `Arbitrary` instances for the following data types: `Pos`,+  `SourcePos`, `ErrorItem`, `Dec`, `ParseError` and `State`. This should+  make testing easier without the need to add orphan instances every time.+  The drawback is that we start to depend on `QuickCheck`, but that's a fair+  price.++* The test suite now uses the combination of Hspec and the+  `hpesc-megaparsec` package, which also improved the latter (that package+  is the recommended way to test Megaparsec parsers).++* The `try` combinator now truly backtracks parser state when its argument+  parser fails (either consuming input or not). Most users will never notice+  the difference though. See #142.++* Added the `dbg` function that should be helpful for debugging.++* Added `observing` primitive combinator that allows to “observe” parse+  errors without ending parsing (they are returned in `Left`, while normal+  results are wrapped in `Right`).++* Further documentation improvements.+ ## Megaparsec 5.0.1  * Derived `NFData` instances for `Pos`, `InvalidPosException`, `SourcePos`,

@@ -83,6 +83,9 @@   continue parsing. Once parsing is finished, several parse errors may be   reported or ignored altogether. +* `observing` allows to “observe” parse errors without ending parsing (they+  are returned in `Left`, while normal results are wrapped in `Right`).+ * `eof` only succeeds at the end of input.  * `token` is used to parse single token.@@ -214,6 +217,9 @@ faster. If you happen to have some other benchmarks, I would appreciate if you add Megaparsec to them and let me know how it performs. +If you think your Megaparsec parser is not efficient enough, take a look+at [these instructions](https://mrkkrp.github.io/megaparsec/tutorials/writing-a-fast-parser.html).+ ## Comparison with other solutions  There are quite a few libraries that can be used for parsing in Haskell,@@ -274,6 +280,8 @@ * Megaparsec is faster.  If you want to see a detailed change log, `CHANGELOG.md` may be helpful.+Also see [this original announcement](https://notehub.org/w7037) for another+comparison.  To be honest Parsec's development has seemingly stagnated. It has no test suite (only three per-bug tests), and all its releases beginning from@@ -313,6 +321,14 @@ * [`hspec-megaparsec`](https://hackage.haskell.org/package/hspec-megaparsec)   — utilities for testing Megaparsec parsers with with   [Hspec](https://hackage.haskell.org/package/hspec).++* [`cassava-megaparsec`](https://hackage.haskell.org/package/cassava-megaparsec) —+  Megaparsec parser of CSV files that plays nicely+  with [Cassava](https://hackage.haskell.org/package/cassava).++* [`tagsoup-megaparsec`](https://hackage.haskell.org/package/tagsoup-megaparsec)+  — a library for easily using [TagSoup](https://hackage.haskell.org/package/tagsoup)+  as a token type in Megaparsec.  ## Authors 

@@ -140,6 +140,8 @@   , ShowToken (..)   , ShowErrorComponent (..)   , parseErrorPretty+    -- * Debugging+  , dbg     -- * Low-level operations   , Stream (..)   , State (..)@@ -177,15 +179,20 @@  -- $many ----- @many p@ applies the parser @p@ /zero/ or more times. Returns a list of--- the returned values of @p@.+-- @many p@ applies the parser @p@ /zero/ or more times and returns a list+-- of the returned values of @p@. Note that if the @p@ parser fails+-- consuming input, then the entire @many p@ parser fails with the error+-- message @p@ produced instead of just stopping iterating. In these cases+-- wrapping @p@ with 'try' may be desirable. ----- > identifier = (:) <$> letter <*> many (alphaNum <|> char '_')+-- > identifier = (:) <$> letter <*> many (alphaNumChar <|> char '_')  -- $some ----- @some p@ applies the parser @p@ /one/ or more times. Returns a list of--- the returned values of @p@.+-- @some p@ applies the parser @p@ /one/ or more times and returns a list of+-- the returned values of @p@. The note about behavior of the combinator in+-- case when @p@ fails consuming input (see 'A.many') applies to 'some' as+-- well. -- -- > word = some letter 

@@ -402,7 +402,7 @@ -- | Case-insensitive equality test for characters.  casei :: Char -> Char -> Bool-casei x y = toLower x == toLower y+casei x y = toUpper x == toUpper y {-# INLINE casei #-}  -- | Case-insensitive 'elem'.

@@ -26,7 +26,8 @@   , ShowToken (..)   , ShowErrorComponent (..)   , parseErrorPretty-  , sourcePosStackPretty )+  , sourcePosStackPretty+  , parseErrorTextPretty ) where  import Control.DeepSeq@@ -40,13 +41,14 @@ import Data.Typeable (Typeable) import GHC.Generics import Prelude hiding (concat)+import Test.QuickCheck hiding (label) import qualified Data.List.NonEmpty as NE import qualified Data.Set           as E  import Text.Megaparsec.Pos  #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))+import Control.Applicative #endif  -- | Data type that is used to represent “unexpected\/expected” items in@@ -62,6 +64,18 @@  instance NFData t => NFData (ErrorItem t) +instance Arbitrary t => Arbitrary (ErrorItem t) where+  arbitrary = oneof+    [+#if !MIN_VERSION_QuickCheck(2,9,0)+      Tokens <$> (NE.fromList . getNonEmpty <$> arbitrary)+    , Label  <$> (NE.fromList . getNonEmpty <$> arbitrary)+#else+      Tokens <$> arbitrary+    , Label  <$> arbitrary+#endif+    , return EndOfInput ]+ -- | The type class defines how to represent information about various -- exceptional situations. Data types that are used as custom data component -- in 'ParseError' must be instances of this type class.@@ -103,6 +117,13 @@   rnf (DecFail str) = rnf str   rnf (DecIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act +instance Arbitrary Dec where+  arbitrary = oneof+    [ sized (\n -> do+        k <- choose (0, n `div` 2)+        DecFail <$> vectorOf k arbitrary)+    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]+ instance ErrorComponent Dec where   representFail        = DecFail   representIndentation = DecIndentation@@ -139,8 +160,31 @@   mappend = (<>)   {-# INLINE mappend #-} -instance (Show t, Typeable t, Show e, Typeable e) => Exception (ParseError t e)+instance ( Show t+         , Typeable t+         , Ord t+         , ShowToken t+         , Show e+         , Typeable e+         , ShowErrorComponent e )+  => Exception (ParseError t e) where+#if MIN_VERSION_base(4,8,0)+  displayException = parseErrorPretty+#endif +instance (Arbitrary t, Ord t, Arbitrary e, Ord e)+    => Arbitrary (ParseError t e) where+  arbitrary = ParseError+    <$>+#if !MIN_VERSION_QuickCheck(2,9,0)+      (NE.fromList . getNonEmpty <$> arbitrary)+#else+      arbitrary+#endif+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary+ -- | Merge two error data structures into one joining their collections of -- message items and preferring longest match. In other words, earlier error -- message is discarded. This may seem counter-intuitive, but 'mergeError'@@ -186,15 +230,41 @@ -- character @ch@, suitable for using in error messages.  charPretty :: Char -> String-charPretty '\0' = "null"-charPretty '\a' = "bell"-charPretty '\b' = "backspace"-charPretty '\t' = "tab"-charPretty '\n' = "newline"-charPretty '\v' = "vertical tab"-charPretty '\f' = "form feed"-charPretty '\r' = "carriage return"-charPretty ' '  = "space"+charPretty '\NUL' = "null (control character)"+charPretty '\SOH' = "start of heading (control character)"+charPretty '\STX' = "start of text (control character)"+charPretty '\ETX' = "end of text (control character)"+charPretty '\EOT' = "end of transmission (control character)"+charPretty '\ENQ' = "enquiry (control character)"+charPretty '\ACK' = "acknowledge (control character)"+charPretty '\BEL' = "bell (control character)"+charPretty '\BS'  = "backspace"+charPretty '\t'   = "tab"+charPretty '\n'   = "newline"+charPretty '\v'   = "vertical tab"+charPretty '\f'   = "form feed (control character)"+charPretty '\r'   = "carriage return"+charPretty '\SO'  = "shift out (control character)"+charPretty '\SI'  = "shift in (control character)"+charPretty '\DLE' = "data link escape (control character)"+charPretty '\DC1' = "device control one (control character)"+charPretty '\DC2' = "device control two (control character)"+charPretty '\DC3' = "device control three (control character)"+charPretty '\DC4' = "device control four (control character)"+charPretty '\NAK' = "negative acknowledge (control character)"+charPretty '\SYN' = "synchronous idle (control character)"+charPretty '\ETB' = "end of transmission block (control character)"+charPretty '\CAN' = "cancel (control character)"+charPretty '\EM'  = "end of medium (control character)"+charPretty '\SUB' = "substitute (control character)"+charPretty '\ESC' = "escape (control character)"+charPretty '\FS'  = "file separator (control character)"+charPretty '\GS'  = "group separator (control character)"+charPretty '\RS'  = "record separator (control character)"+charPretty '\US'  = "unit separator (control character)"+charPretty '\DEL' = "delete (control character)"+charPretty ' '    = "space"+charPretty '\160' = "non-breaking space" charPretty x    = "'" ++ [x] ++ "'"  -- | The type class defines how to print custom data component of@@ -223,9 +293,14 @@                 EQ -> "equal to "                 GT -> "greater than " --- | Pretty-print 'ParseError'. Note that rendered 'String' always ends with--- a newline.+-- | Pretty-print 'ParseError'. The rendered 'String' always ends with a+-- newline. --+-- The function is defined as:+--+-- > parseErrorPretty e =+-- >   sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e+-- -- @since 5.0.0  parseErrorPretty :: ( Ord t@@ -233,14 +308,8 @@                     , ShowErrorComponent e )   => ParseError t e    -- ^ Parse error to render   -> String            -- ^ Result of rendering-parseErrorPretty (ParseError pos us ps xs) =-  sourcePosStackPretty pos ++ ":\n" ++-  if E.null us && E.null ps && E.null xs-    then "unknown parse error\n"-    else concat-      [ messageItemsPretty "unexpected " us-      , messageItemsPretty "expecting "  ps-      , unlines (showErrorComponent <$> E.toAscList xs) ]+parseErrorPretty e =+  sourcePosStackPretty (errorPos e) ++ ":\n" ++ parseErrorTextPretty e  -- | Pretty-print stack of source positions. --@@ -271,3 +340,22 @@ orList (x:|[])  = x orList (x:|[y]) = x ++ " or " ++ y orList xs       = intercalate ", " (NE.init xs) ++ ", or " ++ NE.last xs++-- | Pretty-print textual part of a 'ParseError', that is, everything except+-- stack of source positions. The rendered staring always ends with a new+-- line.+--+-- @since 5.1.0++parseErrorTextPretty :: ( Ord t+                        , ShowToken t+                        , ShowErrorComponent e )+  => ParseError t e    -- ^ Parse error to render+  -> String            -- ^ Result of rendering+parseErrorTextPretty (ParseError _ us ps xs) =+  if E.null us && E.null ps && E.null xs+    then "unknown parse error\n"+    else concat+      [ messageItemsPretty "unexpected " us+      , messageItemsPretty "expecting "  ps+      , unlines (showErrorComponent <$> E.toAscList xs) ]

@@ -54,6 +54,12 @@ -- This is not done by default because in some cases you don't want to allow -- repeating prefix or postfix operators. --+-- If you want to have an operator that is a prefix of another operator in+-- the table, use the following (or similar) wrapper instead of plain+-- 'symbol':+--+-- > op n = (lexeme . try) (string n <* notFollowedBy punctuationChar)+-- -- @makeExprParser@ takes care of all the complexity involved in building an -- expression parser. Here is an example of an expression parser that -- handles prefix signs, postfix increment and basic arithmetic:@@ -80,8 +86,8 @@   -> m a               -- ^ Resulting expression parser makeExprParser = foldl addPrecLevel --- | @addPrecLevel p ops@ adds ability to parse operators in table @ops@ to--- parser @p@.+-- | @addPrecLevel p ops@ adds the ability to parse operators in table @ops@+-- to parser @p@.  addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a addPrecLevel term ops =@@ -92,7 +98,7 @@         las'  = pInfixL (choice las) term'         nas'  = pInfixN (choice nas) term' --- | @pTerm prefix term postfix@ parses term with @term@ surrounded by+-- | @pTerm prefix term postfix@ parses a term with @term@ surrounded by -- optional prefix and postfix unary operators. Parsers @prefix@ and -- @postfix@ are allowed to fail, in this case 'id' is used. 

@@ -105,9 +105,9 @@   -> m () space ch line block = hidden . skipMany $ choice [ch, line, block] --- | This is wrapper for lexemes. Typical usage is to supply first argument--- (parser that consumes white space, probably defined via 'space') and use--- the resulting function to wrap parsers for every lexeme.+-- | This is a wrapper for lexemes. Typical usage is to supply the first+-- argument (parser that consumes white space, probably defined via 'space')+-- and use the resulting function to wrap parsers for every lexeme. -- -- > lexeme  = L.lexeme spaceConsumer -- > integer = lexeme L.integer@@ -148,7 +148,7 @@   -> m String symbol' spc = lexeme spc . C.string' --- | Given comment prefix this function returns parser that skips line+-- | Given comment prefix this function returns a parser that skips line -- comments. Note that it stops just before newline character but doesn't -- consume the newline. Newline is either supposed to be consumed by 'space' -- parser or picked up manually.@@ -158,7 +158,7 @@   -> m () skipLineComment prefix = p >> void (manyTill C.anyChar n)   where p = C.string prefix-        n = lookAhead C.newline+        n = lookAhead (void C.newline) <|> eof  -- | @skipBlockComment start end@ skips non-nested block comment starting -- with @start@ and ending with @end@.@@ -218,11 +218,11 @@  -- | @indentGuard spaceConsumer ord ref@ first consumes all white space -- (indentation) with @spaceConsumer@ parser, then it checks column--- position. Ordering between current indentation level and reference+-- position. Ordering between current indentation level and the reference -- indentation level @ref@ should be @ord@, otherwise the parser fails. On--- success current column position is returned.+-- success the current column position is returned. ----- When you want to parse block of indentation first run this parser with+-- When you want to parse a block of indentation, first run this parser with -- arguments like @indentGuard spaceConsumer GT (unsafePos 1)@ — this will -- make sure you have some indentation. Use returned value to check -- indentation on every subsequent line according to syntax of your@@ -240,7 +240,7 @@     then return actual     else incorrectIndent ord ref actual --- | Parse non-indented construction. This ensures that there is no+-- | Parse a non-indented construction. This ensures that there is no -- indentation before actual data. Useful, for example, as a wrapper for -- top-level function definitions. --@@ -375,7 +375,7 @@ -- Numbers  -- | Parse an integer without sign in decimal representation (according to--- format of integer literals described in Haskell report).+-- the format of integer literals described in the Haskell report). -- -- If you need to parse signed integers, see 'signed' combinator. @@ -389,10 +389,10 @@ decimal = nump "" C.digitChar <?> "decimal integer"  -- | Parse an integer in hexadecimal representation. Representation of--- hexadecimal number is expected to be according to Haskell report except--- for the fact that this parser doesn't parse “0x” or “0X” prefix. It is--- responsibility of the programmer to parse correct prefix before parsing--- the number itself.+-- hexadecimal number is expected to be according to the Haskell report+-- except for the fact that this parser doesn't parse “0x” or “0X” prefix.+-- It is responsibility of the programmer to parse correct prefix before+-- parsing the number itself. -- -- For example you can make it conform to Haskell report like this: --@@ -402,10 +402,10 @@ hexadecimal = nump "0x" C.hexDigitChar <?> "hexadecimal integer"  -- | Parse an integer in octal representation. Representation of octal--- number is expected to be according to Haskell report except for the fact--- that this parser doesn't parse “0o” or “0O” prefix. It is responsibility--- of the programmer to parse correct prefix before parsing the number--- itself.+-- number is expected to be according to the Haskell report except for the+-- fact that this parser doesn't parse “0o” or “0O” prefix. It is+-- responsibility of the programmer to parse correct prefix before parsing+-- the number itself.  octal :: (MonadParsec e s m, Token s ~ Char) => m Integer octal = nump "0o" C.octDigitChar <?> "octal integer"@@ -417,11 +417,11 @@ nump :: MonadParsec e s m => String -> m Char -> m Integer nump prefix baseDigit = read . (prefix ++) <$> some baseDigit --- | Parse floating point value as 'Scientific' number. 'Scientific' is+-- | Parse a floating point value as 'Scientific' number. 'Scientific' is -- great for parsing of arbitrary precision numbers coming from an untrusted -- source. See documentation in "Data.Scientific" for more information.--- Representation of floating point value is expected to be according to--- Haskell report.+-- Representation of the floating point value is expected to be according to+-- the Haskell report. -- -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'.@@ -432,7 +432,7 @@ scientific = label "floating point number" (read <$> f)   where f = (++) <$> some C.digitChar <*> (fraction <|> fExp) --- | Parse floating point number without sign. This is a simple shortcut+-- | Parse a floating point number without sign. This is a simple shortcut -- defined as: -- -- > float = toRealFloat <$> scientific@@ -468,10 +468,10 @@ number = label "number" (read <$> f)   where f = (++) <$> some C.digitChar <*> option "" (fraction <|> fExp) --- | @signed space p@ parser parses optional sign, then if there is a sign--- it will consume optional white space (using @space@ parser), then it runs--- parser @p@ which should return a number. Sign of the number is changed--- according to previously parsed sign.+-- | @signed space p@ parser parses an optional sign, then if there is a+-- sign it will consume optional white space (using @space@ parser), then it+-- runs parser @p@ which should return a number. Sign of the number is+-- changed according to previously parsed sign. -- -- For example, to parse signed integer you can write: --

@@ -39,10 +39,11 @@ import Data.Semigroup import Data.Typeable (Typeable) import GHC.Generics+import Test.QuickCheck import Unsafe.Coerce  #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))+import Control.Applicative import Data.Word (Word) #endif @@ -58,6 +59,9 @@ newtype Pos = Pos Word   deriving (Show, Eq, Ord, Data, Typeable, NFData) +instance Arbitrary Pos where+  arbitrary = unsafePos <$> (getSmall <$> arbitrary `suchThat` (> 0))+ -- | Construction of 'Pos' from an instance of 'Integral'. The function -- throws 'InvalidPosException' when given non-positive argument. Note that -- the function is polymorphic with respect to 'MonadThrow' @m@, so you can@@ -102,6 +106,14 @@       ("Pos", r2) <- lex r1       (x,     r3) <- readsPrec 11 r2       (,r3) <$> mkPos (x :: Integer)++instance Arbitrary SourcePos where+  arbitrary = SourcePos+    <$> sized (\n -> do+          k <- choose (0, n `div` 2)+          vectorOf k arbitrary)+    <*> (unsafePos <$> choose (1, 1000))+    <*> (unsafePos <$> choose (1,  100))  -- | The exception is thrown by 'mkPos' when its argument is not a positive -- number.

@@ -54,7 +54,9 @@   , runParserT'   , parse   , parseMaybe-  , parseTest )+  , parseTest+    -- * Debugging+  , dbg ) where  import Control.DeepSeq@@ -74,8 +76,10 @@ import Data.Semigroup import Data.Set (Set) import Data.Typeable (Typeable)+import Debug.Trace import GHC.Generics import Prelude hiding (all)+import Test.QuickCheck hiding (Result (..), label) import qualified Control.Applicative               as A import qualified Control.Monad.Fail                as Fail import qualified Control.Monad.Trans.Reader        as L@@ -94,7 +98,7 @@ import Text.Megaparsec.Pos  #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), pure)+import Control.Applicative #endif  ----------------------------------------------------------------------------@@ -110,6 +114,17 @@  instance NFData s => NFData (State s) +instance Arbitrary a => Arbitrary (State a) where+  arbitrary = State+    <$> arbitrary+    <*>+#if !MIN_VERSION_QuickCheck(2,9,0)+      (NE.fromList . getNonEmpty <$> arbitrary)+#else+      arbitrary+#endif+    <*> (unsafePos <$> choose (1, 20))+ -- | All information available after parsing. This includes consumption of -- input, success (with returned value) or failure (with parse error), and -- parser state at the end of parsing.@@ -524,8 +539,8 @@   hidden :: m a -> m a   hidden = label "" -  -- | The parser @try p@ behaves like parser @p@, except that it-  -- pretends that it hasn't consumed any input when an error occurs.+  -- | The parser @try p@ behaves like parser @p@, except that it backtracks+  -- parser state when @p@ fails (either consuming input or not).   --   -- This combinator is used whenever arbitrary look ahead is needed. Since   -- it pretends that it hasn't consumed any input when @p@ fails, the@@ -563,16 +578,17 @@    try :: m a -> m a -  -- | @lookAhead p@ parses @p@ without consuming any input.-  ---  -- If @p@ fails and consumes some input, so does @lookAhead@. Combine with-  -- 'try' if this is undesirable.+  -- | If @p@ in @lookAhead p@ succeeds (either consuming input or not) the+  -- whole parser behaves like @p@ succeeded without consuming anything+  -- (parser state is not updated as well). If @p@ fails, @lookAhead@ has no+  -- effect, i.e. it will fail consuming input if @p@ fails consuming input.+  -- Combine with 'try' if this is undesirable.    lookAhead :: m a -> m a    -- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser-  -- does not consume any input and can be used to implement the “longest-  -- match” rule.+  -- /never consumes/ any input and /never modifies/ parser state. It can be+  -- used to implement the “longest match” rule.    notFollowedBy :: m a -> m () @@ -593,6 +609,19 @@     -> m a             -- ^ Original parser     -> m a             -- ^ Parser that can recover from failures +  -- | @observing p@ allows to “observe” failure of @p@ parser, should it+  -- happen, without actually ending parsing, but instead getting the+  -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right'+  -- as usual. Note that this primitive just allows you to observe parse+  -- errors as they happen, it does not backtrack or change how the @p@+  -- parser works in any way.+  --+  -- @since 5.1.0++  observing+    :: m a+    -> m (Either (ParseError (Token s) e) a)+   -- | This parser only succeeds at the end of the input.    eof :: m ()@@ -668,6 +697,7 @@   lookAhead         = pLookAhead   notFollowedBy     = pNotFollowedBy   withRecovery      = pWithRecovery+  observing         = pObserving   eof               = pEof   token             = pToken   tokens            = pTokens@@ -696,7 +726,8 @@  pTry :: ParsecT e s m a -> ParsecT e s m a pTry p = ParsecT $ \s cok _ eok eerr ->-  unParser p s cok eerr eok eerr+  let eerr' err _ = eerr err s+  in unParser p s cok eerr' eok eerr' {-# INLINE pTry #-}  pLookAhead :: ParsecT e s m a -> ParsecT e s m a@@ -736,6 +767,15 @@   in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} +pObserving+  :: ParsecT e s m a+  -> ParsecT e s m (Either (ParseError (Token s) e) a)+pObserving p = ParsecT $ \s cok _ eok _ ->+  let cerr' err s' = cok (Left err) s' mempty+      eerr' err s' = eok (Left err) s' (toHints err)+  in unParser p s (cok . Right) cerr' (eok . Right) eerr'+{-# INLINE pObserving #-}+ pEof :: forall e s m. Stream s => ParsecT e s m () pEof = ParsecT $ \s@(State input (pos:|z) w) _ _ eok eerr ->   case uncons input of@@ -1058,6 +1098,8 @@     notFollowedBy (fst <$> m s) >> return ((),s)   withRecovery r (L.StateT m) = L.StateT $ \s ->     withRecovery (\e -> L.runStateT (r e) s) (m s)+  observing     (L.StateT m) = L.StateT $ \s ->+    fixs s <$> observing (m s)   eof                        = lift eof   token test mt              = lift (token test mt)   tokens e ts                = lift (tokens e ts)@@ -1074,6 +1116,8 @@     notFollowedBy (fst <$> m s) >> return ((),s)   withRecovery r (S.StateT m) = S.StateT $ \s ->     withRecovery (\e -> S.runStateT (r e) s) (m s)+  observing     (S.StateT m) = S.StateT $ \s ->+    fixs s <$> observing (m s)   eof                        = lift eof   token test mt              = lift (token test mt)   tokens e ts                = lift (tokens e ts)@@ -1088,6 +1132,7 @@   notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m   withRecovery r (L.ReaderT m) = L.ReaderT $ \s ->     withRecovery (\e -> L.runReaderT (r e) s) (m s)+  observing     (L.ReaderT m) = L.ReaderT $ observing . m   eof                         = lift eof   token test mt               = lift (token test mt)   tokens e ts                 = lift (tokens e ts)@@ -1104,6 +1149,8 @@     (,mempty) <$> notFollowedBy (fst <$> m)   withRecovery r (L.WriterT m) = L.WriterT $     withRecovery (L.runWriterT . r) m+  observing     (L.WriterT m) = L.WriterT $+    fixs mempty <$> observing m   eof                         = lift eof   token test mt               = lift (token test mt)   tokens e ts                 = lift (tokens e ts)@@ -1120,6 +1167,8 @@     (,mempty) <$> notFollowedBy (fst <$> m)   withRecovery r (S.WriterT m) = S.WriterT $     withRecovery (S.runWriterT . r) m+  observing     (S.WriterT m) = S.WriterT $+    fixs mempty <$> observing m   eof                         = lift eof   token test mt               = lift (token test mt)   tokens e ts                 = lift (tokens e ts)@@ -1134,8 +1183,140 @@   notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m   withRecovery r (IdentityT m) = IdentityT $     withRecovery (runIdentityT . r) m+  observing     (IdentityT m) = IdentityT $ observing m   eof                         = lift eof   token test mt               = lift (token test mt)   tokens e ts                 = lift $ tokens e ts   getParserState              = lift getParserState   updateParserState f         = lift $ updateParserState f++fixs :: s -> Either a (b, s) -> (Either a b, s)+fixs s (Left a)       = (Left a, s)+fixs _ (Right (b, s)) = (Right b, s)+{-# INLINE fixs #-}++----------------------------------------------------------------------------+-- Debugging++-- | @dbg label p@ parser works exactly like @p@, but when it's evaluated it+-- prints information useful for debugging. The @label@ is only used to+-- refer to this parser in the debugging output. This combinator uses the+-- 'trace' function from "Debug.Trace" under the hood.+--+-- Typical usage is to wrap every sub-parser in misbehaving parser with+-- 'dbg' assigning meaningful labels. Then give it a shot and go through the+-- print-out. As of current version, this combinator prints all available+-- information except for /hints/, which are probably only interesting to+-- the maintainer of Megaparsec itself and may be quite verbose to output in+-- general. Let me know if you would like to be able to see hints as part of+-- debugging output.+--+-- The output itself is pretty self-explanatory, although the following+-- abbreviations should be clarified (they are derived from low-level source+-- code):+--+--     * @COK@ — “consumed OK”. The parser consumed input and succeeded.+--     * @CERR@ — “consumed error”. The parser consumed input and failed.+--     * @EOK@ — “empty OK”. The parser succeeded without consuming input.+--     * @EERR@ — “empty error”. The parser failed without consuming input.+--+-- Due to how input streams are represented (see 'Stream'), we need to+-- traverse entire input twice (calculating length before and after @p@+-- parser) to understand what part of input was matched and consumed. This+-- makes this combinator very inefficient, be sure to remove it from your+-- code once you have finished with debugging.+--+-- Finally, it's not possible to lift this function into some monad+-- transformers without introducing surprising behavior (e.g. unexpected+-- state backtracking) or adding otherwise redundant constraints (e.g.+-- 'Show' instance for state), so this helper is only available for+-- 'ParsecT' monad, not 'MonadParsec' in general.+--+-- @since 5.1.0++dbg :: forall e s m a.+  ( Stream s+  , ShowToken (Token s)+  , ShowErrorComponent e+  , Show a )+  => String            -- ^ Debugging label+  -> ParsecT e s m a   -- ^ Parser to debug+  -> ParsecT e s m a   -- ^ Parser that prints debugging messages+dbg lbl p = ParsecT $ \s cok cerr eok eerr ->+  let l = dbgLog lbl :: DbgItem s e a -> String+      cok' x s' hs = flip trace (cok x s' hs) $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)+      cerr' err s' = flip trace (cerr err s') $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err)+      eok' x s' hs = flip trace (eok x s' hs) $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)+      eerr' err s' = flip trace (eerr err s') $+        l (DbgIn (unfold (stateInput s))) +++        l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err)+  in unParser p s cok' cerr' eok' eerr'++-- | Single piece of info to be rendered with 'dbgLog'.++data DbgItem s e a+  = DbgIn   [Token s]+  | DbgCOK  [Token s] a+  | DbgCERR [Token s] (ParseError (Token s) e)+  | DbgEOK  [Token s] a+  | DbgEERR [Token s] (ParseError (Token s) e)++-- | Render a single piece of debugging info.++dbgLog :: (ShowToken (Token s), ShowErrorComponent e, Show a, Ord (Token s))+  => String            -- ^ Debugging label+  -> DbgItem s e a     -- ^ Information to render+  -> String            -- ^ Rendered result+dbgLog lbl item = prefix msg+  where+    prefix = unlines . fmap ((lbl ++ "> ") ++) . lines+    msg = case item of+      DbgIn   ts   ->+        "IN: " ++ showStream ts+      DbgCOK  ts a ->+        "MATCH (COK): " ++ showStream ts ++ "\nVALUE: " ++ show a+      DbgCERR ts e ->+        "MATCH (CERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e+      DbgEOK  ts a ->+        "MATCH (EOK): " ++ showStream ts ++ "\nVALUE: " ++ show a+      DbgEERR ts e ->+        "MATCH (EERR): " ++ showStream ts ++ "\nERROR:\n" ++ parseErrorPretty e++-- | Pretty-print a list of tokens.++showStream :: ShowToken t => [t] -> String+showStream ts =+  case NE.nonEmpty ts of+    Nothing -> "<EMPTY>"+    Just ne ->+      let (h, r) = splitAt 40 (showTokens ne)+      in if null r then h else h ++ " <…>"++-- | Calculate difference in length of two input streams from given parser+-- 'State's.++streamDelta :: Stream s+  => State s           -- ^ State of parser before consumption+  -> State s           -- ^ State of parser after consumption+  -> Int               -- ^ Number of consumed tokens+streamDelta s0 s1 = streamLength (stateInput s0) - streamLength (stateInput s1)+  where streamLength s = length (unfold s)++-- | Extract given number of tokens from the stream.++streamTake :: Stream s => Int -> s -> [Token s]+streamTake n s = take n (unfold s)++-- | Custom version of 'unfold' that matches signature of 'uncons' method in+-- 'Stream' type class we use.++unfold :: Stream s => s -> [Token s]+unfold s = case uncons s of+  Nothing -> []+  Just (t, s') -> t : unfold s'

@@ -27,7 +27,7 @@ -- POSSIBILITY OF SUCH DAMAGE.  name:                 megaparsec-version:              5.0.1+version:              5.1.0 cabal-version:        >= 1.10 license:              BSD2 license-file:         LICENSE.md@@ -46,7 +46,7 @@   This is industrial-strength monadic parser combinator library. Megaparsec   is a fork of Parsec library originally written by Daan Leijen. -extra-source-files:   AUTHORS.md+extra-doc-files:      AUTHORS.md                     , CHANGELOG.md                     , README.md @@ -56,7 +56,8 @@   default:            False  library-  build-depends:      base         >= 4.6   && < 5.0+  build-depends:      QuickCheck   >= 2.7   && < 3.0+                    , base         >= 4.6   && < 5.0                     , bytestring   >= 0.2   && < 0.11                     , containers   >= 0.5   && < 0.6                     , deepseq      >= 1.3   && < 1.5@@ -98,59 +99,36 @@     ghc-options:      -O2 -Wall   default-language:   Haskell2010 -test-suite old-tests-  main-is:            Main.hs-  hs-source-dirs:     old-tests-  type:               exitcode-stdio-1.0-  if flag(dev)-    ghc-options:      -Wall -Werror-  else-    ghc-options:      -O2 -Wall-  other-modules:      Bugs-                    , Bugs.Bug2-                    , Bugs.Bug6-                    , Bugs.Bug9-                    , Bugs.Bug35-                    , Bugs.Bug39-                    , Util-  build-depends:      base                 >= 4.6 && < 5.0-                    , HUnit                >= 1.2 && < 1.4-                    , megaparsec           >= 5.0.1-                    , test-framework       >= 0.6 && < 1.0-                    , test-framework-hunit >= 0.2 && < 0.4-  default-language:   Haskell2010- test-suite tests-  main-is:            Main.hs+  main-is:            Spec.hs   hs-source-dirs:     tests   type:               exitcode-stdio-1.0   if flag(dev)     ghc-options:      -Wall -Werror   else     ghc-options:      -O2 -Wall-  other-modules:      Char-                    , Combinator-                    , Error-                    , Expr-                    , Lexer-                    , Perm-                    , Pos-                    , Prim-                    , Util-  build-depends:      base           >= 4.6   && < 5.0-                    , HUnit          >= 1.2   && < 1.4-                    , QuickCheck     >= 2.8.2 && < 3.0-                    , bytestring     >= 0.2   && < 0.11-                    , containers     >= 0.5   && < 0.6-                    , exceptions     >= 0.6   && < 0.9-                    , megaparsec     >= 5.0.1-                    , mtl            >= 2.0   && < 3.0-                    , scientific     >= 0.3.1 && < 0.4-                    , test-framework >= 0.6   && < 1.0-                    , test-framework-hunit       >= 0.3 && < 0.4-                    , test-framework-quickcheck2 >= 0.3 && < 0.4-                    , text           >= 0.2   && < 1.3-                    , transformers   >= 0.4   && < 0.6+  other-modules:      Test.Hspec.Megaparsec+                    , Test.Hspec.Megaparsec.AdHoc+                    , Text.Megaparsec.CharSpec+                    , Text.Megaparsec.CombinatorSpec+                    , Text.Megaparsec.ErrorSpec+                    , Text.Megaparsec.ExprSpec+                    , Text.Megaparsec.LexerSpec+                    , Text.Megaparsec.PermSpec+                    , Text.Megaparsec.PosSpec+                    , Text.Megaparsec.PrimSpec+  build-depends:      QuickCheck   >= 2.7   && < 3.0+                    , base         >= 4.6   && < 5.0+                    , bytestring   >= 0.2   && < 0.11+                    , containers   >= 0.5   && < 0.6+                    , exceptions   >= 0.6   && < 0.9+                    , hspec        >= 2.0   && < 3.0+                    , hspec-expectations >= 0.5 && < 0.8+                    , megaparsec   >= 5.1.0+                    , mtl          >= 2.0   && < 3.0+                    , scientific   >= 0.3.1 && < 0.4+                    , text         >= 0.2   && < 1.3+                    , transformers >= 0.4   && < 0.6    if !impl(ghc >= 8.0)     -- packages providing modules that moved into base-4.9.0.0@@ -169,11 +147,11 @@     ghc-options:      -O2 -Wall -Werror   else     ghc-options:      -O2 -Wall-  build-depends:      base       >= 4.6  && < 5.0-                    , bytestring >= 0.10 && < 0.11-                    , criterion  >= 0.6.2.1 && < 1.2-                    , megaparsec >= 5.0.1-                    , text       >= 0.2  && < 1.3+  build-depends:      base         >= 4.6  && < 5.0+                    , bytestring   >= 0.10 && < 0.11+                    , criterion    >= 0.6.2.1 && < 1.2+                    , megaparsec   >= 5.1.0+                    , text         >= 0.2  && < 1.3   default-language:   Haskell2010  source-repository head

@@ -1,16 +0,0 @@-module Bugs (bugs) where--import Test.Framework--import qualified Bugs.Bug2-import qualified Bugs.Bug6-import qualified Bugs.Bug9-import qualified Bugs.Bug35-import qualified Bugs.Bug39--bugs :: [Test]-bugs = [ Bugs.Bug2.main-       , Bugs.Bug6.main-       , Bugs.Bug9.main-       , Bugs.Bug35.main-       , Bugs.Bug39.main ]

@@ -1,32 +0,0 @@-module Bugs.Bug2 (main) where--import Control.Applicative (empty)-import Control.Monad (void)--import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--sc :: Parser ()-sc = L.space (void spaceChar) empty empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--stringLiteral :: Parser String-stringLiteral = lexeme $ char '"' >> manyTill L.charLiteral (char '"')--main :: Test-main =-  testCase "Control Char Parsing (#2)" $-  parseString "\"test\\^Bstring\"" @?= "test\^Bstring"- where-   parseString :: String -> String-   parseString input =-      case parse stringLiteral "Example" input of-        Left{} -> error "Parse failure"-        Right str -> str

@@ -1,35 +0,0 @@-module Bugs.Bug35 (main) where--import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--trickyFloats :: [String]-trickyFloats =-    [ "1.5339794352098402e-118"-    , "2.108934760892056e-59"-    , "2.250634744599241e-19"-    , "5.0e-324"-    , "5.960464477539063e-8"-    , "0.25996181067141905"-    , "0.3572019862807257"-    , "0.46817723004874223"-    , "0.9640035681058178"-    , "4.23808622486133"-    , "4.540362294799751"-    , "5.212384849884261"-    , "13.958257048123212"-    , "32.96176575630599"-    , "38.47735512322269" ]--testBatch :: Assertion-testBatch = mapM_ testFloat trickyFloats-  where testFloat x = parse (L.float :: Parser Double) "" x-          @?= Right (read x :: Double)--main :: Test-main = testCase "Output of Text.Megaparsec.Lexer.float (#35)" testBatch

@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}--module Bugs.Bug39 (main) where--import Control.Applicative (empty)-import Control.Monad (void)-#if MIN_VERSION_base(4,7,0)-import Data.Either (isLeft, isRight)-#endif--import Text.Megaparsec-import Text.Megaparsec.String-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--#if !MIN_VERSION_base(4,7,0)-isRight, isLeft :: Either a b -> Bool-isRight (Right _) = True-isRight _         = False-isLeft  (Left _ ) = True-isLeft  _         = False-#endif--shouldFail :: [String]-shouldFail = [" 1", " +1", " -1"]--shouldSucceed :: [String]-shouldSucceed = ["1", "+1", "-1", "+ 1 ", "- 1 ", "1 "]--sc :: Parser ()-sc = L.space (void spaceChar) empty empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--integer :: Parser Integer-integer = lexeme $ L.signed sc L.integer--testBatch :: Assertion-testBatch = mapM_ (f testFail)    shouldFail >>-            mapM_ (f testSucceed) shouldSucceed-    where f           t a = t (parse integer "" a) a-          testFail    x a = assertBool-                            ("Should fail on " ++ show a) (isLeft x)-          testSucceed x a = assertBool-                            ("Should succeed on " ++ show a) (isRight x)--main :: Test-main = testCase "Lexer should fail on leading whitespace (#39)" testBatch

@@ -1,22 +0,0 @@-module Bugs.Bug6 (main) where--import Text.Megaparsec-import Text.Megaparsec.String--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--import Util--main :: Test-main =-  testCase "Look-ahead preserving error location (#6)" $-  parseErrors variable "return" @?= ["'return' is a reserved keyword"]--variable :: Parser String-variable = do-  x <- lookAhead (some letterChar)-  if x == "return"-    then fail "'return' is a reserved keyword"-    else string x

@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}--module Bugs.Bug9 (main) where--import Control.Applicative (empty)-import Control.Monad (void)--import Text.Megaparsec-import Text.Megaparsec.Expr-import Text.Megaparsec.String (Parser)-import qualified Text.Megaparsec.Lexer as L--import Test.Framework-import Test.Framework.Providers.HUnit-import Test.HUnit hiding (Test)--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<$))-#endif--data Expr = Const Integer | Op Expr Expr deriving Show--main :: Test-main =-  testCase "Tracing of current position in error message (#9)"-  $ result @?= ["unexpected '>'", "expecting end of input or operator"]-  where-    result :: [String]-    result = parseErrors parseTopLevel "4 >> 5"---- Syntax analysis--sc :: Parser ()-sc = L.space (void spaceChar) empty empty--lexeme :: Parser a -> Parser a-lexeme = L.lexeme sc--integer :: Parser Integer-integer = lexeme L.integer--operator :: String -> Parser String-operator = L.symbol sc--parseTopLevel :: Parser Expr-parseTopLevel = parseExpr <* eof--parseExpr :: Parser Expr-parseExpr = makeExprParser (Const <$> integer) table-  where table = [[ InfixL (Op <$ operator ">>>") ]]

@@ -1,6 +0,0 @@-import Test.Framework--import Bugs (bugs)--main :: IO ()-main = defaultMain [testGroup "Bugs" bugs]

@@ -1,12 +0,0 @@-module Util where--import Text.Megaparsec-import Text.Megaparsec.String (Parser)---- | Returns the error messages associated with a failed parse.--parseErrors :: Parser a -> String -> [String]-parseErrors p input =-  case parse p "" input of-    Left err -> drop 1 $ lines $ parseErrorPretty err-    Right _  -> []

@@ -1,246 +0,0 @@------ QuickCheck tests for Megaparsec's character parsers.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Char (tests) where--import Data.Char-import Data.List (findIndex, isPrefixOf)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Error--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>))-#endif--tests :: Test-tests = testGroup "Character parsers"-  [ testProperty "newline"         prop_newline-  , testProperty "crlf"            prop_crlf-  , testProperty "eol"             prop_eol-  , testProperty "tab"             prop_tab-  , testProperty "space"           prop_space-  , testProperty "controlChar"     prop_controlChar-  , testProperty "spaceChar"       prop_spaceChar-  , testProperty "upperChar"       prop_upperChar-  , testProperty "lowerChar"       prop_lowerChar-  , testProperty "letterChar"      prop_letterChar-  , testProperty "alphaNumChar"    prop_alphaNumChar-  , testProperty "printChar"       prop_printChar-  , testProperty "digitChar"       prop_digitChar-  , testProperty "hexDigitChar"    prop_hexDigitChar-  , testProperty "octDigitChar"    prop_octDigitChar-  , testProperty "markChar"        prop_markChar-  , testProperty "numberChar"      prop_numberChar-  , testProperty "punctuationChar" prop_punctuationChar-  , testProperty "symbolChar"      prop_symbolChar-  , testProperty "separatorChar"   prop_separatorChar-  , testProperty "asciiChar"       prop_asciiChar-  , testProperty "latin1Char"      prop_latin1Char-  , testProperty "charCategory"    prop_charCategory-  , testProperty "char"            prop_char-  , testProperty "char'"           prop_char'-  , testProperty "anyChar"         prop_anyChar-  , testProperty "oneOf"           prop_oneOf-  , testProperty "oneOf'"          prop_oneOf'-  , testProperty "noneOf"          prop_noneOf-  , testProperty "noneOf'"         prop_noneOf'-  , testProperty "string"          prop_string-  , testProperty "string'"         prop_string'_0-  , testProperty "string' (case)"  prop_string'_1 ]--instance Arbitrary GeneralCategory where-  arbitrary = elements [minBound..maxBound]--prop_newline :: String -> Property-prop_newline = checkChar newline (== '\n') (tkn '\n')--prop_crlf :: String -> Property-prop_crlf = checkString crlf "\r\n" (==)--prop_eol :: String -> Property-prop_eol s = checkParser eol r s-  where h = head s-        r | s == "\n"   = Right "\n"-          | s == "\r\n" = Right "\r\n"-          | null s      = posErr 0 s [ueof, elabel "end of line"]-          | h == '\n'   = posErr 1 s [utok (s !! 1), eeof]-          | h /= '\r'   = posErr 0 s [utok h, elabel "end of line"]-          | "\r\n" `isPrefixOf` s = posErr 2 s [utok (s !! 2), eeof]-          | otherwise   = posErr 0 s [ utoks (take 2 s)-                                     , utok '\r'-                                     , elabel "end of line" ]--prop_tab :: String -> Property-prop_tab = checkChar tab (== '\t') (tkn '\t')--prop_space :: String -> Property-prop_space s = checkParser space r s-  where r = case findIndex (not . isSpace) s of-              Just x  ->-                  let ch = s !! x-                  in posErr x s-                     [ utok ch-                     , utok ch-                     , elabel "white space"-                     , eeof ]-              Nothing -> Right ()--prop_controlChar :: String -> Property-prop_controlChar = checkChar controlChar isControl (lbl "control character")--prop_spaceChar :: String -> Property-prop_spaceChar = checkChar spaceChar isSpace (lbl "white space")--prop_upperChar :: String -> Property-prop_upperChar = checkChar upperChar isUpper (lbl "uppercase letter")--prop_lowerChar :: String -> Property-prop_lowerChar = checkChar lowerChar isLower (lbl "lowercase letter")--prop_letterChar :: String -> Property-prop_letterChar = checkChar letterChar isAlpha (lbl "letter")--prop_alphaNumChar :: String -> Property-prop_alphaNumChar = checkChar alphaNumChar isAlphaNum-  (lbl "alphanumeric character")--prop_printChar :: String -> Property-prop_printChar = checkChar printChar isPrint (lbl "printable character")--prop_digitChar :: String -> Property-prop_digitChar = checkChar digitChar isDigit (lbl "digit")--prop_octDigitChar :: String -> Property-prop_octDigitChar = checkChar octDigitChar isOctDigit (lbl "octal digit")--prop_hexDigitChar :: String -> Property-prop_hexDigitChar = checkChar hexDigitChar isHexDigit (lbl "hexadecimal digit")--prop_markChar :: String -> Property-prop_markChar = checkChar markChar isMark (lbl "mark character")--prop_numberChar :: String -> Property-prop_numberChar = checkChar numberChar isNumber (lbl "numeric character")--prop_punctuationChar :: String -> Property-prop_punctuationChar = checkChar punctuationChar isPunctuation (lbl "punctuation")--prop_symbolChar :: String -> Property-prop_symbolChar = checkChar symbolChar isSymbol (lbl "symbol")--prop_separatorChar :: String -> Property-prop_separatorChar = checkChar separatorChar isSeparator (lbl "separator")--prop_asciiChar :: String -> Property-prop_asciiChar = checkChar asciiChar isAscii (lbl "ASCII character")--prop_latin1Char :: String -> Property-prop_latin1Char = checkChar latin1Char isLatin1 (lbl "Latin-1 character")--prop_charCategory :: GeneralCategory -> String -> Property-prop_charCategory cat = checkChar (charCategory cat) p (lbl $ categoryName cat)-  where p c = generalCategory c == cat--prop_char :: Char -> String -> Property-prop_char c = checkChar (char c) (== c) (tkn c)--prop_char' :: Char -> String -> Property-prop_char' c s = checkParser (char' c) r s-  where h = head s-        l | isLower c = [c, toUpper c]-          | isUpper c = [c, toLower c]-          | otherwise = [c]-        r | null s         = posErr 0 s $ ueof : (etok <$> l)-          | length s == 1 && (h `elemi` l) = Right h-          | h `notElemi` l = posErr 0 s $ utok h : (etok <$> l)-          | otherwise      = posErr 1 s [utok (s !! 1), eeof]--prop_anyChar :: String -> Property-prop_anyChar = checkChar anyChar (const True) (lbl "character")--prop_oneOf :: String -> String -> Property-prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing--prop_oneOf' :: String -> String -> Property-prop_oneOf' a = checkChar (oneOf' a) (`elemi` a) Nothing--prop_noneOf :: String -> String -> Property-prop_noneOf a = checkChar (noneOf a) (`notElem` a) Nothing--prop_noneOf' :: String -> String -> Property-prop_noneOf' a = checkChar (noneOf' a) (`notElemi` a) Nothing--prop_string :: String -> String -> Property-prop_string a = checkString (string a) a (==)--prop_string'_0 :: String -> String -> Property-prop_string'_0 a = checkString (string' a) a casei---- | 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--prop_string'_1 :: String -> Property-prop_string'_1 a = forAll (fuzzyCase a) $ \s ->-  checkString (string' a) a casei s---- | Case-insensitive equality test for characters.--casei :: Char -> Char -> Bool-casei x y = toLower x == toLower y---- | Case-insensitive 'elem'.--elemi :: Char -> String -> Bool-elemi c = any (casei c)---- | Case-insensitive 'notElem'.--notElemi :: Char -> String -> Bool-notElemi c = not . elemi c--tkn :: Char -> Maybe (ErrorItem Char)-tkn = Just . Tokens . (:|[])--lbl :: String -> Maybe (ErrorItem Char)-lbl = Just . Label . NE.fromList

@@ -1,233 +0,0 @@------ QuickCheck tests for Megaparsec's generic parser combinators.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--module Combinator (tests) where--import Control.Applicative-import Data.Char (isLetter, isDigit)-import Data.List (intersperse)-import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Combinator--import Util--tests :: Test-tests = testGroup "Generic parser combinators"-  [ testProperty "combinator between"   prop_between-  , testProperty "combinator choice"    prop_choice-  , testProperty "combinator count"     prop_count-  , testProperty "combinator count'"    prop_count'-  , testProperty "combinator eitherP"   prop_eitherP-  , testProperty "combinator endBy"     prop_endBy-  , testProperty "combinator endBy1"    prop_endBy1-  , testProperty "combinator manyTill"  prop_manyTill-  , testProperty "combinator someTill"  prop_someTill-  , testProperty "combinator option"    prop_option-  , testProperty "combinator sepBy"     prop_sepBy-  , testProperty "combinator sepBy1"    prop_sepBy1-  , testProperty "combinator sepEndBy"  prop_sepEndBy-  , testProperty "combinator sepEndBy1" prop_sepEndBy1-  , testProperty "combinator skipMany"  prop_skipMany-  , testProperty "combinator skipSome"  prop_skipSome ]--prop_between :: String -> Char -> NonNegative Int -> String -> Property-prop_between pre c n' post = checkParser p r s-  where p = between (string pre) (string post) (many (char c))-        n = getNonNegative n'-        b = length $ takeWhile (== c) post-        r | b > 0 = posErr (length pre + n + b) s $ etoks post : etok c :-            [if length post == b-              then ueof-              else utoks [post !! b]]-          | otherwise = Right z-        z = replicate n c-        s = pre ++ z ++ post--prop_choice :: NonEmptyList Char -> Char -> Property-prop_choice cs' s' = checkParser p r s-  where cs = getNonEmpty cs'-        p = choice $ char <$> cs-        r | s' `elem` cs = Right s'-          | otherwise    = posErr 0 s $ utok s' : (etok <$> cs)-        s = [s']--prop_count :: Int -> NonNegative Int -> Property-prop_count n x' = checkParser p r s-  where x = getNonNegative x'-        p = count n (char 'x')-        r = simpleParse (count' n n (char 'x')) s-        s = replicate x 'x'--prop_count' :: Int -> Int -> NonNegative Int -> Property-prop_count' m n x' = checkParser p r s-  where x = getNonNegative x'-        p = count' m n (char 'x')-        r | n <= 0 || m > n  =-              if x == 0-                then Right ""-                else posErr 0 s [utok 'x', eeof]-          | m <= x && x <= n = Right s-          | x < m            = posErr x s [ueof, etok 'x']-          | otherwise        = posErr n s [utok 'x', eeof]-        s = replicate x 'x'--prop_eitherP :: Char -> Property-prop_eitherP ch = checkParser p r s-  where p = eitherP letterChar digitChar-        r | isLetter ch = Right (Left  ch)-          | isDigit  ch = Right (Right ch)-          | otherwise   = posErr 0 s [utok ch, elabel "letter", elabel "digit"]-        s = pure ch--prop_endBy :: NonNegative Int -> Char -> Property-prop_endBy n' c = checkParser p r s-  where n = getNonNegative n'-        p = endBy (char 'a') (char '-')-        r | c == 'a' && n == 0 = posErr 1 s [ueof, etok '-']-          | c == 'a'           = posErr (g n) s [utok 'a', etok '-']-          | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a', eeof]-          | c /= '-'           = posErr (g n) s $ utok c :-            (if n > 0 then etok '-' else eeof) :-            [etok 'a' | n == 0]-          | otherwise = Right (replicate n 'a')-        s = intersperse '-' (replicate n 'a') ++ [c]--prop_endBy1 :: NonNegative Int -> Char -> Property-prop_endBy1 n' c = checkParser p r s-  where n = getNonNegative n'-        p = endBy1 (char 'a') (char '-')-        r | c == 'a' && n == 0 = posErr 1 s [ueof, etok '-']-          | c == 'a'           = posErr (g n) s [utok 'a', etok '-']-          | c == '-' && n == 0 = posErr 0 s [utok '-', etok 'a']-          | c /= '-'           = posErr (g n) s $ utok c :-            [etok '-' | n > 0] ++ [etok 'a' | n == 0]-          | otherwise = Right (replicate n 'a')-        s = intersperse '-' (replicate n 'a') ++ [c]--prop_manyTill :: NonNegative Int -> NonNegative Int-              -> NonNegative Int -> Property-prop_manyTill a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar-        r | c == 0    = posErr (a + b) s [ueof, etok 'c', elabel "letter"]-          | otherwise = let (pre, post) = break (== 'c') s-                        in Right (pre, drop 1 post)-        s = abcRow a b c--prop_someTill :: NonNegative Int -> NonNegative Int-              -> NonNegative Int -> Property-prop_someTill a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar-        r | null s    = posErr 0 s [ueof, elabel "letter"]-          | c == 0    = posErr (a + b) s [ueof, etok 'c', elabel "letter"]-          | s == "c"  = posErr 1 s [ueof, etok 'c', elabel "letter"]-          | head s == 'c' = Right ("c", drop 2 s)-          | otherwise = let (pre, post) = break (== 'c') s-                        in Right (pre, drop 1 post)-        s = abcRow a b c--prop_option :: String -> String -> String -> Property-prop_option d a s = checkParser p r s-  where p = option d (string a)-        r = simpleParse (fromMaybe d <$> optional (string a)) s--prop_sepBy :: NonNegative Int -> Maybe Char -> Property-prop_sepBy n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepBy (char 'a') (char '-')-        r | isNothing c' = Right (replicate n 'a')-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]-          | c == '-'  = posErr (length s) s [ueof, etok 'a']-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_sepBy1 :: NonNegative Int -> Maybe Char -> Property-prop_sepBy1 n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepBy1 (char 'a') (char '-')-        r | isNothing c' && n >= 1 = Right (replicate n 'a')-          | isNothing c' = posErr 0 s [ueof, etok 'a']-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a']-          | c == '-'  = posErr (length s) s [ueof, etok 'a']-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_sepEndBy :: NonNegative Int -> Maybe Char -> Property-prop_sepEndBy n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepEndBy (char 'a') (char '-')-        a = Right $ replicate n 'a'-        r | isNothing c' = a-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]-          | c == '-'  = a-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_sepEndBy1 :: NonNegative Int -> Maybe Char -> Property-prop_sepEndBy1 n' c' = checkParser p r s-  where n = getNonNegative n'-        c = fromJust c'-        p = sepEndBy1 (char 'a') (char '-')-        a = Right $ replicate n 'a'-        r | isNothing c' && n >= 1 = a-          | isNothing c' = posErr 0 s [ueof, etok 'a']-          | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [utok c, etok 'a']-          | c == '-'  = a-          | otherwise = posErr (g n) s [utok c, etok '-', eeof]-        s = intersperse '-' (replicate n 'a') ++ maybeToList c'--prop_skipMany :: Char -> NonNegative Int -> String -> Property-prop_skipMany c n' a = checkParser p r s-  where p = skipMany (char c) *> string a-        n = getNonNegative n'-        r = simpleParse (many (char c) >> string a) s-        s = replicate n c ++ a--prop_skipSome :: Char -> NonNegative Int -> String -> Property-prop_skipSome c n' a = checkParser p r s-  where p = skipSome (char c) *> string a-        n = getNonNegative n'-        r = simpleParse (some (char c) >> string a) s-        s = replicate n c ++ a--g :: Int -> Int-g x = x + if x > 0 then x - 1 else 0

@@ -1,152 +0,0 @@------ QuickCheck tests for Megaparsec's parse errors.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Error (tests) where--import Data.Function (on)-import Data.List (isInfixOf)-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid ((<>))-import Data.Set (Set)-import qualified Data.List.NonEmpty as NE-import qualified Data.Set           as E--import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion, (@?=))-import Test.QuickCheck--import Text.Megaparsec.Error-import Text.Megaparsec.Pos--import Util ()--#if !MIN_VERSION_base(4,8,0)-import Data.Foldable (Foldable, all)-import Data.Monoid (mempty)-import Prelude hiding (all)-#endif--tests :: Test-tests = testGroup "Parse errors"-  [ testProperty "monoid left identity"               prop_monoid_left_id-  , testProperty "monoid right identity"              prop_monoid_right_id-  , testProperty "monoid associativity"               prop_monoid_assoc-  , testProperty "consistency of Show/Read"           prop_showReadConsistency-  , testProperty "position of merged error"           prop_mergeErrorPos-  , testProperty "unexpected items in merged error"   prop_mergeErrorUnexpected-  , testProperty "expected items in merged error"     prop_mergeErrorExpected-  , testProperty "custom items in merged error"       prop_mergeErrorCustom-  , testCase     "showTokens (String instance)"       case_showTokens-  , testCase     "rendering of unknown parse error"   case_ppUnknownError-  , testProperty "source position in rendered error"  prop_ppSourcePos-  , testProperty "unexpected items in rendered error" prop_ppUnexpected-  , testProperty "expected items in rendered error"   prop_ppExpected-  , testProperty "custom data in rendered error"      prop_ppCustom ]--type PE = ParseError Char Dec--prop_monoid_left_id :: PE -> Property-prop_monoid_left_id x = mempty <> x === x .&&.-  mempty { errorPos = errorPos x } <> x === x--prop_monoid_right_id :: PE -> Property-prop_monoid_right_id x = x <> mempty === x .&&.-  mempty { errorPos = errorPos x } <> x === x--prop_monoid_assoc :: PE -> PE -> PE -> Property-prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z)--prop_showReadConsistency :: PE -> Property-prop_showReadConsistency x = read (show x) === x--prop_mergeErrorPos :: PE -> PE -> Property-prop_mergeErrorPos e1 e2 =-  errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2)--prop_mergeErrorUnexpected :: PE -> PE -> Property-prop_mergeErrorUnexpected = checkMergedItems errorUnexpected--prop_mergeErrorExpected :: PE -> PE -> Property-prop_mergeErrorExpected = checkMergedItems errorExpected--prop_mergeErrorCustom :: PE -> PE -> Property-prop_mergeErrorCustom = checkMergedItems errorCustom--checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property-checkMergedItems f e1 e2 = f (e1 <> e2) === r-  where r = case (compare `on` errorPos) e1 e2 of-              LT -> f e2-              EQ -> (E.union `on` f) e1 e2-              GT -> f e1--case_showTokens :: Assertion-case_showTokens = mapM_ (\(x,y) -> showTokens (NE.fromList x) @?= y)-  [ ("\r\n", "crlf newline")-  , ("\0",   "null")-  , ("\a",   "bell")-  , ("\b",   "backspace")-  , ("\t",   "tab")-  , ("\n",   "newline")-  , ("\v",   "vertical tab")-  , ("\f",   "form feed")-  , ("\r",   "carriage return")-  , (" ",    "space")-  , ("a",    "'a'")-  , ("foo",  "\"foo\"") ]--case_ppUnknownError :: Assertion-case_ppUnknownError =-  parseErrorPretty (err :: PE) @?= "1:1:\nunknown parse error\n"-  where-    err = ParseError-      { errorPos        = initialPos "" :| []-      , errorUnexpected = E.empty-      , errorExpected   = E.empty-      , errorCustom     = E.empty }--prop_ppSourcePos :: PE -> Property-prop_ppSourcePos = checkPresence errorPos sourcePosPretty--prop_ppUnexpected :: PE -> Property-prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent--prop_ppExpected :: PE -> Property-prop_ppExpected = checkPresence errorExpected showErrorComponent--prop_ppCustom :: PE -> Property-prop_ppCustom = checkPresence errorCustom showErrorComponent--checkPresence :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property-checkPresence g r e = property (all f (g e))-  where rendered = parseErrorPretty e-        f x = r x `isInfixOf` rendered

@@ -1,189 +0,0 @@------ QuickCheck tests for Megaparsec's expression parsers.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies     #-}--module Expr (tests) where--import Control.Applicative (some, (<|>))-import Data.Char (isDigit, digitToInt)--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Expr-import Text.Megaparsec.Prim--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)-#endif--tests :: Test-tests = testGroup "Expression parsers"-  [ testProperty "correctness of expression parser" prop_correctness-  , testProperty "error message on empty input"     prop_empty_error-  , testProperty "error message on missing term"    prop_missing_term-  , testProperty "error message on missing op"      prop_missing_op ]---- Algebraic structures to build abstract syntax tree of our expression.--data Node-  = Val Integer   -- ^ literal value-  | Neg Node      -- ^ negation (prefix unary)-  | Fac Node      -- ^ factorial (postfix unary)-  | Mod Node Node -- ^ modulo-  | Sum Node Node -- ^ summation (addition)-  | Sub Node Node -- ^ subtraction-  | Pro Node Node -- ^ product-  | Div Node Node -- ^ division-  | Exp Node Node -- ^ exponentiation-    deriving (Eq, Show)--instance Enum Node where-  fromEnum (Val _)   = 0-  fromEnum (Neg _)   = 0-  fromEnum (Fac _)   = 0-  fromEnum (Mod _ _) = 0-  fromEnum (Exp _ _) = 1-  fromEnum (Pro _ _) = 2-  fromEnum (Div _ _) = 2-  fromEnum (Sum _ _) = 3-  fromEnum (Sub _ _) = 3-  toEnum   _         = error "Oops!"--instance Ord Node where-  x `compare` y = fromEnum x `compare` fromEnum y--showNode :: Node -> String-showNode (Val x)     = show x-showNode n@(Neg x)   = "-" ++ showGT n x-showNode n@(Fac x)   = showGT n x ++ "!"-showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y-showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y-showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y-showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y-showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y-showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y--showGT :: Node -> Node -> String-showGT parent node = (if node > parent then showCmp else showNode) node--showGE :: Node -> Node -> String-showGE parent node = (if node >= parent then showCmp else showNode) node--showCmp :: Node -> String-showCmp node = (if fromEnum node == 0 then showNode else inParens) node--inParens :: Node -> String-inParens x = "(" ++ showNode x ++ ")"--instance Arbitrary Node where-  arbitrary = sized arbitraryN0--arbitraryN0 :: Int -> Gen Node-arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf)-                          , (9, arbitraryN1 n) ]-  where leaf = arbitraryN1 (n `div` 2)--arbitraryN1 :: Int -> Gen Node-arbitraryN1 n =- frequency [ (1, Neg <$> arbitraryN2 n)-           , (1, Fac <$> arbitraryN2 n)-           , (7, arbitraryN2 n)]--arbitraryN2 :: Int -> Gen Node-arbitraryN2 0 = Val . getNonNegative <$> arbitrary-arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf-  where leaf = arbitraryN0 (n `div` 2)---- Some helpers are put here since we don't want to depend on--- "Text.Megaparsec.Lexer".--lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a-lexeme p = p <* hidden space--symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String-symbol = lexeme . string--parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a-parens = between (symbol "(") (symbol ")")--integer :: (MonadParsec e s m, Token s ~ Char) => m Integer-integer = lexeme (read <$> some digitChar <?> "integer")---- Here we use table of operators that makes use of all features of--- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex--- but valid expressions and render them to get their textual--- representation.--expr :: (MonadParsec e s m, Token s ~ Char) => m Node-expr = makeExprParser term table--term :: (MonadParsec e s m, Token s ~ Char) => m Node-term = parens expr <|> (Val <$> integer) <?> "term"--table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]]-table = [ [ Prefix  (symbol "-" *> pure Neg)-          , Postfix (symbol "!" *> pure Fac)-          , InfixN  (symbol "%" *> pure Mod) ]-        , [ InfixR  (symbol "^" *> pure Exp) ]-        , [ InfixL  (symbol "*" *> pure Pro)-          , InfixL  (symbol "/" *> pure Div) ]-        , [ InfixL  (symbol "+" *> pure Sum)-          , InfixL  (symbol "-" *> pure Sub)] ]--prop_correctness :: Node -> Property-prop_correctness node = checkParser expr (Right node) (showNode node)--prop_empty_error :: Property-prop_empty_error = checkParser expr r s-  where r = posErr 0 s [ueof, elabel "term"]-        s = ""--prop_missing_term :: Char -> Property-prop_missing_term c = checkParser expr r s-  where r | c `elem` "-(" = posErr 1 s [ueof, elabel "term"]-          | isDigit c     = Right . Val . fromIntegral . digitToInt $ c-          | otherwise     = posErr 0 s [utok c, elabel "term"]-        s = pure c--prop_missing_op :: Node -> Node -> Property-prop_missing_op a b = checkParser expr r s-  where a' = inParens a-        c = s !! n-        n = succ $ length a'-        r | c == '-'  = Right $ Sub a b-          | otherwise = posErr n s [utok c, eeof, elabel "operator"]-        s = a' ++ " " ++ inParens b

@@ -1,402 +0,0 @@------ QuickCheck tests for Megaparsec's lexer.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TupleSections    #-}-{-# LANGUAGE TypeFamilies     #-}--module Lexer (tests) where--import Control.Applicative (empty)-import Control.Monad (void)-import Data.Char-  ( readLitChar-  , showLitChar-  , isDigit-  , isAlphaNum-  , isSpace-  , toLower )-import Data.List (findIndices, isInfixOf, find)-import Data.Maybe-import Data.Scientific (fromFloatDigits)-import Numeric (showInt, showHex, showOct, showSigned)--import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.HUnit (Assertion)-import Test.QuickCheck--import Text.Megaparsec.Error-import Text.Megaparsec.Lexer-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String-import qualified Text.Megaparsec.Char as C--import Util--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*), (<*>), (<$))-#endif--tests :: Test-tests = testGroup "Lexer"-  [ testProperty "space combinator"       prop_space-  , testProperty "symbol combinator"      prop_symbol-  , testProperty "symbol' combinator"     prop_symbol'-  , testCase     "skipBlockCommentNested" case_skipBlockCommentNested-  , testProperty "indentLevel"            prop_indentLevel-  , testProperty "incorrectIndent"        prop_incorrectIndent-  , testProperty "indentGuard combinator" prop_indentGuard-  , testProperty "nonIndented combinator" prop_nonIndented-  , testProperty "indentBlock combinator" prop_indentBlock-  , testProperty "indentBlock (many)"     prop_indentMany-  , testProperty "lineFold"               prop_lineFold-  , testProperty "charLiteral"            prop_charLiteral-  , testProperty "integer"                prop_integer-  , testProperty "decimal"                prop_decimal-  , testProperty "hexadecimal"            prop_hexadecimal-  , testProperty "octal"                  prop_octal-  , testProperty "float 0"                prop_float_0-  , testProperty "float 1"                prop_float_1-  , testProperty "number 0"               prop_number_0-  , testProperty "number 1"               prop_number_1-  , testProperty "number 2 (signed)"      prop_number_2-  , testProperty "signed"                 prop_signed ]---- White space--mkWhiteSpace :: Gen String-mkWhiteSpace = concat <$> listOf whiteUnit-  where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]--mkSymbol :: Gen String-mkSymbol = (++) <$> symbolName <*> whiteChars--mkInterspace :: String -> Int -> Gen String-mkInterspace x n = oneof [si, mkIndent x n]-  where si = (++ x) <$> listOf (elements " \t")--mkIndent :: String -> Int -> Gen String-mkIndent x n = (++) <$> mkIndent' x n <*> eol-  where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]--mkIndent' :: String -> Int -> Gen String-mkIndent' x n = concat <$> sequence [spc, sym, tra]-  where spc = frequency [(5, vectorOf n itm), (1, listOf itm)]-        tra = listOf itm-        itm = elements " \t"-        sym = return x--whiteChars :: Gen String-whiteChars = listOf (elements "\t\n ")--whiteLine :: Gen String-whiteLine = commentOut <$> arbitrary `suchThat` goodEnough-  where commentOut x = "//" ++ x ++ "\n"-        goodEnough x = '\n' `notElem` x--whiteBlock :: Gen String-whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough-  where commentOut x = "/*" ++ x ++ "*/"-        goodEnough x = not $ "*/" `isInfixOf` x--symbolName :: Gen String-symbolName = listOf $ arbitrary `suchThat` isAlphaNum--sc :: Parser ()-sc = space (void $ C.oneOf " \t") empty empty--scn :: Parser ()-scn = space (void C.spaceChar) l b-  where l = skipLineComment "//"-        b = skipBlockComment "/*" "*/"--prop_space :: Property-prop_space = forAll mkWhiteSpace (checkParser p r)-  where p = scn-        r = Right ()--prop_symbol :: Maybe Char -> Property-prop_symbol t = forAll mkSymbol $ \s ->-  parseSymbol (symbol scn) id s t--prop_symbol' :: Maybe Char -> Property-prop_symbol' t = forAll mkSymbol $ \s ->-  parseSymbol (symbol' scn) (fmap toLower) s t--parseSymbol-  :: (String -> Parser String)-  -> (String -> String)-  -> String-  -> Maybe Char-  -> Property-parseSymbol p' f s' t = checkParser p r s-  where p = p' (f g)-        r | g == s || isSpace (last s) = Right g-          | otherwise = posErr (length s - 1) s [utok (last s), eeof]-        g = takeWhile (not . isSpace) s-        s = s' ++ maybeToList t--case_skipBlockCommentNested :: Assertion-case_skipBlockCommentNested = checkCase p r s-  where p = space (void C.spaceChar) empty-              (skipBlockCommentNested "/*" "*/") <* eof-        r = Right ()-        s = " /* foo bar /* baz */ quux */ "---- Indentation--prop_indentLevel :: SourcePos -> Property-prop_indentLevel pos = p /=\ sourceColumn pos-  where p = setPosition pos >> indentLevel--prop_incorrectIndent :: Ordering -> Pos -> Pos -> Property-prop_incorrectIndent ord ref actual = checkParser p r s-  where p = incorrectIndent ord ref actual :: Parser ()-        r = posErr 0 s (ii ord ref actual)-        s = ""--prop_indentGuard :: NonNegative (Small Int) -> Property-prop_indentGuard n =-  forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) ->-    let r | col0 <= pos1 = posErr 0 s (ii GT pos1 col0)-          | col1 /= col0 = posErr (getIndent l1 + g 1) s (ii EQ col0 col1)-          | col2 <= col0 = posErr (getIndent l2 + g 2) s (ii GT col0 col2)-          | otherwise    = Right ()-        (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-        fragments = [l0,l1,l2]-        g x = sum (length <$> take x fragments)-        s = concat fragments-    in checkParser p r s-  where mki = mkIndent sbla (getSmall $ getNonNegative n)-        p  = ip GT pos1 >>=-          \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn-        ip = indentGuard scn-        sp = void (symbol sc sbla <* C.eol)--prop_nonIndented :: Property-prop_nonIndented = forAll (mkIndent sbla 0) $ \s ->-  let i = getIndent s-      r | i == 0    = Right sbla-        | otherwise = posErr i s (ii EQ pos1 (getCol s))-  in checkParser p r s-  where p = nonIndented scn (symbol scn sbla)--prop_indentBlock :: Maybe (Positive (Small Int)) -> Property-prop_indentBlock mn'' = forAll mkBlock $ \(l0,l1,l2,l3,l4) ->-  let r | col1 <= col0 =-          posErr (getIndent l1 + g 1) s [utok (head sblb), eeof]-        | isJust mn && col1 /= ib' =-          posErr (getIndent l1 + g 1) s (ii EQ ib' col1)-        | col2 <= col1 =-          posErr (getIndent l2 + g 2) s (ii GT col1 col2)-        | col3 == col2 =-          posErr (getIndent l3 + g 3) s [utok (head sblb), etoks sblc]-        | col3 <= col0 =-          posErr (getIndent l3 + g 3) s [utok (head sblb), eeof]-        | col3 < col1 =-          posErr (getIndent l3 + g 3) s (ii EQ col1 col3)-        | col3 > col1 =-          posErr (getIndent l3 + g 3) s (ii EQ col2 col3)-        | col4 <= col3 =-          posErr (getIndent l4 + g 4) s (ii GT col3 col4)-        | otherwise = Right (sbla, [(sblb, [sblc]), (sblb, [sblc])])-      (col0, col1, col2, col3, col4) =-        (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)-      fragments = [l0,l1,l2,l3,l4]-      g x = sum (length <$> take x fragments)-      s = concat fragments-  in checkParser p r s-  where mkBlock = do-          l0 <- mkIndent sbla 0-          l1 <- mkIndent sblb ib-          l2 <- mkIndent sblc (ib + 2)-          l3 <- mkIndent sblb ib-          l4 <- mkIndent' sblc (ib + 2)-          return (l0,l1,l2,l3,l4)-        p = lvla-        lvla = indentBlock scn $ IndentMany mn      (l sbla) lvlb <$ b sbla-        lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb-        lvlc = indentBlock scn $ IndentNone                  sblc <$ b sblc-        b    = symbol sc-        l x  = return . (x,)-        mn'  = getSmall . getPositive <$> mn''-        mn   = unsafePos . fromIntegral <$> mn'-        ib   = fromMaybe 2 mn'-        ib'  = unsafePos (fromIntegral ib)--prop_indentMany :: Property-prop_indentMany = forAll (mkIndent sbla 0) (checkParser p r)-  where r = Right (sbla, [])-        p = lvla-        lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla-        lvlb = b sblb-        b    = symbol sc-        l x  = return . (x,)--prop_lineFold :: Property-prop_lineFold = forAll mkFold $ \(l0,l1,l2) ->-  let r | end0 && col1 <= col0 =-          posErr (getIndent l1 + g 1) s (ii GT col0 col1)-        | end1 && col2 <= col0 =-          posErr (getIndent l2 + g 2) s (ii GT col0 col2)-        | otherwise = Right (sbla, sblb, sblc)-      (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)-      (end0, end1)       = (getEnd l0, getEnd l1)-      fragments = [l0,l1,l2]-      g x = sum (length <$> take x fragments)-      s = concat fragments-  in checkParser p r s-  where-    mkFold = do-      l0 <- mkInterspace sbla 0-      l1 <- mkInterspace sblb 1-      l2 <- mkInterspace sblc 1-      return (l0,l1,l2)-    p = lineFold scn $ \sc' -> do-          a <- symbol sc' sbla-          b <- symbol sc' sblb-          c <- symbol scn sblc-          return (a, b, c)-    getEnd x = last x == '\n'--getIndent :: String -> Int-getIndent = length . takeWhile isSpace--getCol :: String -> Pos-getCol x = sourceColumn .-  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x--sbla, sblb, sblc :: String-sbla = "aaa"-sblb = "bbb"-sblc = "ccc"--ii :: Ordering -> Pos -> Pos -> [EC]-ii ord ref actual = [cstm (DecIndentation ord ref actual)]--pos1 :: Pos-pos1 = unsafePos 1---- Character and string literals--prop_charLiteral :: String -> Bool -> Property-prop_charLiteral t i = checkParser charLiteral r s-  where b = listToMaybe $ readLitChar s-        (h, g) = fromJust b-        r | isNothing b = posErr 0 s $ elabel "literal character" :-            [ if null s then ueof else utok (head s) ]-          | null g      = Right h-          | otherwise   = posErr l s [utok (head g), eeof]-        l = length s - length g-        s = if null t || i then t else showLitChar (head t) (tail t)---- Numbers--prop_integer :: NonNegative Integer -> Int -> Property-prop_integer n' i = checkParser integer r s-  where (r, s) = quasiCorrupted n' i showInt "integer"--prop_decimal :: NonNegative Integer -> Int -> Property-prop_decimal n' i = checkParser decimal r s-  where (r, s) = quasiCorrupted n' i showInt "decimal integer"--prop_hexadecimal :: NonNegative Integer -> Int -> Property-prop_hexadecimal n' i = checkParser hexadecimal r s-  where (r, s) = quasiCorrupted n' i showHex "hexadecimal integer"--prop_octal :: NonNegative Integer -> Int -> Property-prop_octal n' i = checkParser octal r s-  where (r, s) = quasiCorrupted n' i showOct "octal integer"--prop_float_0 :: NonNegative Double -> Property-prop_float_0 n' = checkParser float r s-  where n = getNonNegative n'-        r = Right n-        s = show n--prop_float_1 :: Maybe (NonNegative Integer) -> Property-prop_float_1 n' = checkParser float r s-  where r | isNothing n' = posErr 0 s [ueof, elabel "floating point number"]-          | otherwise    = posErr (length s) s-            [ueof, etok '.', etok 'E', etok 'e', elabel "digit"]-        s = maybe "" (show . getNonNegative) n'--prop_number_0 :: Either (NonNegative Integer) (NonNegative Double) -> Property-prop_number_0 n' = checkParser number r s-  where r = Right $ case n' of-              Left  x -> fromIntegral . getNonNegative $ x-              Right x -> fromFloatDigits . getNonNegative $ x-        s = either (show . getNonNegative) (show . getNonNegative) n'--prop_number_1 :: Property-prop_number_1 = checkParser number r s-  where r = posErr 0 s [ueof, elabel "number"]-        s = ""--prop_number_2 :: Either Integer Double -> Property-prop_number_2 n = checkParser p r s-  where p = signed (hidden C.space) number-        r = Right $ case n of-              Left  x -> fromIntegral x-              Right x -> fromFloatDigits x-        s = either show show n--prop_signed :: Integer -> Int -> Bool -> Property-prop_signed n i plus = checkParser p r s-  where p = signed (hidden C.space) integer-        r | i > length z = Right n-          | otherwise = posErr i s $ utok '?' :-            (if i <= 0 then [etok '+', etok '-'] else []) ++-            [elabel $ if isNothing . find isDigit $ take i s-                        then "integer"-                        else "rest of integer"] ++-            [eeof | i > head (findIndices isDigit s)]-        z = let bar = showSigned showInt 0 n ""-            in if n < 0 || plus then bar else '+' : bar-        s = if i <= length z then take i z ++ "?" ++ drop i z else z--quasiCorrupted-  :: NonNegative Integer-  -> Int-  -> (Integer -> String -> String)-  -> String-  -> (Either (ParseError Char Dec) Integer, String)-quasiCorrupted n' i shower l = (r, s)-  where n = getNonNegative n'-        r | i > length z = Right n-          | otherwise    = posErr i s $ utok '?' :-            [ eeof | i > 0 ] ++-            [if i <= 0 || null l-               then elabel l-               else elabel $ "rest of " ++ l]-        z = shower n ""-        s = if i <= length z then take i z ++ "?" ++ drop i z else z

@@ -1,51 +0,0 @@------ QuickCheck tests for Megaparsec, main module.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--module Main (main) where--import Test.Framework (defaultMain)--import qualified Pos-import qualified Error-import qualified Prim-import qualified Combinator-import qualified Char-import qualified Expr-import qualified Perm-import qualified Lexer--main :: IO ()-main = defaultMain-  [ Pos.tests-  , Error.tests-  , Prim.tests-  , Combinator.tests-  , Char.tests-  , Expr.tests-  , Perm.tests-  , Lexer.tests ]

@@ -1,103 +0,0 @@------ QuickCheck tests for Megaparsec's permutation phrases parsers.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--module Perm (tests) where--import Control.Applicative-import Data.List (nub, elemIndices)--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Char-import Text.Megaparsec.Lexer (integer)-import Text.Megaparsec.Perm--import Util--tests :: Test-tests = testGroup "Permutation phrases parsers"-  [ testProperty "permutation parser pure" prop_pure-  , testProperty "permutation test 0"      prop_perm_0-  , testProperty "combinator (<$$>)"       prop_ddcomb ]--data CharRows = CharRows-  { getChars :: (Char, Char, Char)-  , getInput :: String }-  deriving (Eq, Show)--instance Arbitrary CharRows where-  arbitrary = do-    chars@(a,b,c) <- arbitrary `suchThat` different-    an            <- arbitrary-    bn            <- arbitrary-    cn            <- arbitrary-    input <- concat <$> shuffle-             [ replicate an a-             , replicate bn b-             , replicate cn c]-    return $ CharRows chars input-      where different (a,b,c) = let l = [a,b,c] in l == nub l--prop_pure :: Integer -> Property-prop_pure n = makePermParser p /=\ n-  where p = id <$?> (succ n, pure n)--prop_perm_0 :: String -> Char -> CharRows -> Property-prop_perm_0 a' c' v = checkParser (makePermParser p) r s-  where (a,b,c) = getChars v-        p = (,,) <$?> (a', some (char a))-                 <||> char b-                 <|?> (c', char c)-        r | length bis > 1 && (length cis <= 1 || head bis < head cis) =-              posErr (bis !! 1) s $ [utok b, eeof] ++-              [etok a | a `notElem` preb] ++-              [etok c | c `notElem` preb]-          | length cis > 1 =-            posErr (cis !! 1) s $ [utok c] ++-            [etok a | a `notElem` prec] ++-            [if b `elem` prec then eeof else etok b]-          | b `notElem` s = posErr (length s) s $ [ueof, etok b] ++-                            [etok a | a `notElem` s || last s == a] ++-                            [etok c | c `notElem` s]-          | otherwise = Right ( if a `elem` s then filter (== a) s else a'-                              , b-                              , if c `elem` s then c else c' )-        bis  = elemIndices b s-        preb = take (bis !! 1) s-        cis  = elemIndices c s-        prec = take (cis !! 1) s-        s    = getInput v--prop_ddcomb :: NonNegative Integer -> Property-prop_ddcomb n' = checkParser (makePermParser p) r s-  where p = succ <$$> integer-        r = Right (succ n)-        n = getNonNegative n'-        s = show n

@@ -1,121 +0,0 @@------ QuickCheck tests for Megaparsec's textual source positions.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# OPTIONS -fno-warn-orphans #-}--module Pos (tests) where--import Control.Monad.Catch-import Data.Function (on)-import Data.List (isInfixOf, elemIndices)-import Data.Semigroup ((<>))--import Test.Framework-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck--import Text.Megaparsec.Pos-import Util (updatePosString)--#if !MIN_VERSION_base(4,8,0)-import Data.Word (Word)-#endif--tests :: Test-tests = testGroup "Textual source positions"-  [ testProperty "creation of Pos (mkPos)"              prop_mkPos-  , testProperty "creation of Pos (unsafePos)"          prop_unsafePos-  , testProperty "consistency of Show/Read for Pos"     prop_showReadPos-  , testProperty "Ord instance of Pos"                  prop_ordPos-  , testProperty "Semigroup instance of Pos"            prop_semigroupPos-  , testProperty "construction of initial position"     prop_initialPos-  , testProperty "consistency of Show/Read for SourcePos" prop_showReadSourcePos-  , testProperty "pretty-printing: visible file path"   prop_ppFilePath-  , testProperty "pretty-printing: visible line"        prop_ppLine-  , testProperty "pretty-printing: visible column"      prop_ppColumn-  , testProperty "default updating of source position"  prop_defaultUpdatePos ]--prop_mkPos :: Word -> Property-prop_mkPos x' = case mkPos x' of-  Left  e -> fromException e === Just InvalidPosException-  Right x -> unPos x === x'--prop_unsafePos :: Positive Word -> Property-prop_unsafePos x' = unPos (unsafePos x) === x-  where x = getPositive x'--prop_showReadPos :: Pos -> Property-prop_showReadPos x = read (show x) === x--prop_ordPos :: Pos -> Pos -> Property-prop_ordPos x y = compare x y === (compare `on` unPos) x y--prop_semigroupPos :: Pos -> Pos -> Property-prop_semigroupPos x y =-  x <> y === unsafePos (unPos x + unPos y) .&&.-  unPos (x <> y) === unPos x + unPos y--prop_initialPos :: String -> Property-prop_initialPos fp =-  sourceName   x === fp          .&&.-  sourceLine   x === unsafePos 1 .&&.-  sourceColumn x === unsafePos 1-  where x = initialPos fp--prop_showReadSourcePos :: SourcePos -> Property-prop_showReadSourcePos x = read (show x) === x--prop_ppFilePath :: SourcePos -> Property-prop_ppFilePath x = property $-  sourceName x `isInfixOf` sourcePosPretty x--prop_ppLine :: SourcePos -> Property-prop_ppLine x = property $-  (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x--prop_ppColumn :: SourcePos -> Property-prop_ppColumn x = property $-  (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x--prop_defaultUpdatePos :: Pos -> SourcePos -> String -> Property-prop_defaultUpdatePos w pos "" = updatePosString w pos "" === pos-prop_defaultUpdatePos w pos s =-  sourceName updated === sourceName pos .&&.-  unPos (sourceLine updated) === unPos (sourceLine pos) + inclines .&&.-  cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` unPos w == 0))-  where-    updated  = updatePosString w pos s-    cols     = unPos (sourceColumn updated)-    newlines = elemIndices '\n' s-    inclines = fromIntegral (length newlines)-    total    = fromIntegral (length s)-    mincols  =-      if null newlines-        then total + unPos (sourceColumn pos)-        else total - fromIntegral (maximum newlines)

@@ -1,1017 +0,0 @@------ QuickCheck tests for Megaparsec's primitive parser combinators.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE FlexibleContexts  #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE Rank2Types        #-}-{-# LANGUAGE RecordWildCards   #-}-{-# LANGUAGE TypeFamilies      #-}-{-# OPTIONS -fno-warn-orphans  #-}--module Prim (tests) where--import Control.Applicative-import Control.Monad.Cont-import Control.Monad.Except-import Control.Monad.Identity-import Control.Monad.Reader-import Data.Char (isLetter, toUpper, chr)-import Data.Foldable (asum)-import Data.List (isPrefixOf, foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (maybeToList, fromMaybe)-import Data.Proxy-import Data.Set (Set)-import Data.Word (Word8)-import Prelude hiding (span)-import qualified Control.Monad.State.Lazy    as L-import qualified Control.Monad.State.Strict  as S-import qualified Control.Monad.Writer.Lazy   as L-import qualified Control.Monad.Writer.Strict as S-import qualified Data.ByteString.Char8       as B-import qualified Data.ByteString.Lazy.Char8  as BL-import qualified Data.List.NonEmpty          as NE-import qualified Data.Set                    as E-import qualified Data.Text                   as T-import qualified Data.Text.Lazy              as TL--import Test.Framework-import Test.Framework.Providers.HUnit (testCase)-import Test.Framework.Providers.QuickCheck2 (testProperty)-import Test.QuickCheck hiding (label)-import Test.HUnit (Assertion)--import Text.Megaparsec.Char-import Text.Megaparsec.Combinator-import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String--import Pos ()-import Error ()-import Util--tests :: Test-tests = testGroup "Primitive parser combinators"-  [ testProperty "Stream lazy byte string"             prop_byteStringL-  , testProperty "Stream lazy byte string (pos)"       prop_byteStringL_pos-  , testProperty "Stream strict byte string"           prop_byteStringS-  , testProperty "Stream strict byte string (pos)"     prop_byteStringS_pos-  , testProperty "Stream lazy text"                    prop_textL-  , testProperty "Stream lazy text (pos)"              prop_textL_pos-  , testProperty "Stream strict text"                  prop_textS-  , testProperty "Stream strict text (pos)"            prop_textS_pos-  , testProperty "position in custom stream, eof"      prop_cst_eof-  , testProperty "position in custom stream, token"    prop_cst_token-  , testProperty "position in custom stream, tokens"   prop_cst_tokens-  , testProperty "ParsecT functor"                     prop_functor-  , testProperty "ParsecT applicative (<*>)"           prop_applicative_0-  , testProperty "ParsecT applicative (<*>) meok-cerr" prop_applicative_1-  , testProperty "ParsecT applicative (*>)"            prop_applicative_2-  , testProperty "ParsecT applicative (<*)"            prop_applicative_3-  , testProperty "ParsecT alternative empty and (<|>)" prop_alternative_0-  , testProperty "ParsecT alternative (<|>)"           prop_alternative_1-  , testProperty "ParsecT alternative (<|>) pos"       prop_alternative_2-  , testProperty "ParsecT alternative (<|>) hints"     prop_alternative_3-  , testProperty "ParsecT alternative many"            prop_alternative_4-  , testProperty "ParsecT alternative some"            prop_alternative_5-  , testProperty "ParsecT alternative optional"        prop_alternative_6-  , testProperty "ParsecT monad return"                prop_monad_0-  , testProperty "ParsecT monad (>>)"                  prop_monad_1-  , testProperty "ParsecT monad (>>=)"                 prop_monad_2-  , testProperty "ParsecT monad fail"                  prop_monad_3-  , testProperty "ParsecT monad laws: left identity"   prop_monad_left_id-  , testProperty "ParsecT monad laws: right identity"  prop_monad_right_id-  , testProperty "ParsecT monad laws: associativity"   prop_monad_assoc-  , testProperty "ParsecT monad io (liftIO)"           prop_monad_io-  , testProperty "ParsecT monad reader ask"   prop_monad_reader_ask-  , testProperty "ParsecT monad reader local" prop_monad_reader_local-  , testProperty "ParsecT monad state get"    prop_monad_state_get-  , testProperty "ParsecT monad state put"    prop_monad_state_put-  , testProperty "ParsecT monad cont"         prop_monad_cont-  , testProperty "ParsecT monad error: throw" prop_monad_error_throw-  , testProperty "ParsecT monad error: catch" prop_monad_error_catch-  , testProperty "combinator unexpected"      prop_unexpected-  , testProperty "combinator failure"                  prop_failure-  , testProperty "combinator label"                    prop_label-  , testProperty "combinator hidden hints"             prop_hidden_0-  , testProperty "combinator hidden error"             prop_hidden_1-  , testProperty "combinator try"                      prop_try-  , testProperty "combinator lookAhead"                prop_lookAhead_0-  , testProperty "combinator lookAhead hints"          prop_lookAhead_1-  , testProperty "combinator lookAhead messages"       prop_lookAhead_2-  , testCase     "combinator lookAhead cerr"           case_lookAhead_3-  , testProperty "combinator notFollowedBy"       prop_notFollowedBy_0-  , testProperty "combinator notFollowedBy twice" prop_notFollowedBy_1-  , testProperty "combinator notFollowedBy eof"   prop_notFollowedBy_2-  , testCase     "combinator notFollowedBy cerr"  case_notFollowedBy_3a-  , testCase     "combinator notFollowedBy cerr"  case_notFollowedBy_3b-  , testCase     "combinator notFollowedBy eerr"  case_notFollowedBy_4a-  , testCase     "combinator notFollowedBy eerr"  case_notFollowedBy_4b-  , testProperty "combinator withRecovery"             prop_withRecovery_0-  , testCase     "combinator withRecovery eok"         case_withRecovery_1-  , testCase     "combinator withRecovery meerr-rcerr" case_withRecovery_2-  , testCase     "combinator withRecovery meerr-reok"  case_withRecovery_3a-  , testCase     "combinator withRecovery meerr-reok"  case_withRecovery_3b-  , testCase     "combinator withRecovery mcerr-rcok"  case_withRecovery_4a-  , testCase     "combinator withRecovery mcerr-rcok"  case_withRecovery_4b-  , testCase     "combinator withRecovery mcerr-rcerr" case_withRecovery_5-  , testCase     "combinator withRecovery mcerr-reok"  case_withRecovery_6a-  , testCase     "combinator withRecovery mcerr-reok"  case_withRecovery_6b-  , testCase     "combinator withRecovery mcerr-reerr" case_withRecovery_7-  , testCase     "combinator eof return value"    case_eof-  , testProperty "combinator token"                    prop_token-  , testProperty "combinator tokens"                   prop_tokens_0-  , testProperty "combinator tokens (consumption)"     prop_tokens_1-  , testProperty "parser state position"               prop_state_pos-  , testProperty "parser state position (push)"        prop_state_pushPosition-  , testProperty "parser state position (pop)"         prop_state_popPosition-  , testProperty "parser state input"                  prop_state_input-  , testProperty "parser state tab width"              prop_state_tab-  , testProperty "parser state general"                prop_state-  , testProperty "parseMaybe"                          prop_parseMaybe-  , testProperty "custom state parsing"                prop_runParser'-  , testProperty "custom state parsing (transformer)"  prop_runParserT'-  , testProperty "state on failure (mplus)"         prop_stOnFail_0-  , testProperty "state on failure (tab)"           prop_stOnFail_1-  , testProperty "state on failure (eof)"           prop_stOnFail_2-  , testProperty "state on failure (notFollowedBy)" prop_stOnFail_3-  , testProperty "ReaderT try"              prop_ReaderT_try-  , testProperty "ReaderT notFollowedBy"    prop_ReaderT_notFollowedBy-  , testProperty "StateT alternative (<|>)" prop_StateT_alternative-  , testProperty "StateT lookAhead"         prop_StateT_lookAhead-  , testProperty "StateT notFollowedBy"     prop_StateT_notFollowedBy-  , testProperty "WriterT"                  prop_WriterT ]--instance Arbitrary a => Arbitrary (State a) where-  arbitrary = State-    <$> arbitrary-    <*> arbitrary-    <*> (unsafePos <$> choose (1, 20))---- Various instances of Stream--prop_byteStringL :: Word8 -> NonNegative Int -> Property-prop_byteStringL ch' n = parse p "" (BL.pack s) === Right s-  where p  = many (char ch) :: Parsec Dec BL.ByteString String-        s  = replicate (getNonNegative n) ch-        ch = byteToChar ch'--prop_byteStringL_pos :: Pos -> SourcePos -> Char -> Property-prop_byteStringL_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy BL.ByteString) w pos ch--prop_byteStringS :: Word8 -> NonNegative Int -> Property-prop_byteStringS ch' n = parse p "" (B.pack s) === Right s-  where p  = many (char ch) :: Parsec Dec B.ByteString String-        s  = replicate (getNonNegative n) ch-        ch = byteToChar ch'--prop_byteStringS_pos :: Pos -> SourcePos -> Char -> Property-prop_byteStringS_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy B.ByteString) w pos ch--byteToChar :: Word8 -> Char-byteToChar = chr . fromIntegral--prop_textL :: Char -> NonNegative Int -> Property-prop_textL ch n = parse p "" (TL.pack s) === Right s-  where p = many (char ch) :: Parsec Dec TL.Text String-        s = replicate (getNonNegative n) ch--prop_textL_pos :: Pos -> SourcePos -> Char -> Property-prop_textL_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy TL.Text) w pos ch--prop_textS :: Char -> NonNegative Int -> Property-prop_textS ch n = parse p "" (T.pack s) === Right s-  where p = many (char ch) :: Parsec Dec T.Text String-        s = replicate (getNonNegative n) ch--prop_textS_pos :: Pos -> SourcePos -> Char -> Property-prop_textS_pos w pos ch =-  updatePos (Proxy :: Proxy String) w pos ch ===-  updatePos (Proxy :: Proxy T.Text) w pos ch---- Custom stream of tokens and position advancing---- | This data type will represent tokens in input stream for the purposes--- of next several tests.--data Span = Span-  { spanStart :: SourcePos-  , spanEnd   :: SourcePos-  , spanBody  :: NonEmpty Char-  } deriving (Eq, Ord, Show)--instance Stream [Span] where-  type Token [Span] = Span-  uncons [] = Nothing-  uncons (t:ts) = Just (t, ts)-  updatePos _ _ _ (Span start end _) = (start, end)--instance Arbitrary Span where-  arbitrary = do-    start <- arbitrary-    end   <- arbitrary `suchThat` (> start)-    Span start end <$> arbitrary--type CustomParser = Parsec Dec [Span]--prop_cst_eof :: State [Span] -> Property-prop_cst_eof st =-  (not . null . stateInput) st ==> (runParser' p st === r)-  where-    p = eof :: CustomParser ()-    h = head (stateInput st)-    apos = let (_:|z) = statePos st in spanStart h :| z-    r = (st { statePos = apos }, Left ParseError-      { errorPos        = apos-      , errorUnexpected = E.singleton (Tokens (nes h))-      , errorExpected   = E.singleton EndOfInput-      , errorCustom     = E.empty })--prop_cst_token :: State [Span] -> Span -> Property-prop_cst_token st@State {..} span = runParser' p st === r-  where-    p = pSpan span-    h = head stateInput-    (apos, npos) =-      let z = NE.tail statePos-      in (spanStart h :| z, spanEnd h :| z)-    r | null stateInput =-        ( st-        , Left ParseError-          { errorPos        = statePos-          , errorUnexpected = E.singleton EndOfInput-          , errorExpected   = E.singleton (Tokens $ nes span)-          , errorCustom     = E.empty } )-      | spanBody h == spanBody span =-          ( st { statePos = npos-               , stateInput = tail stateInput }-          , Right span )-      | otherwise =-          ( st { statePos = apos }-          , Left ParseError-            { errorPos        = apos-            , errorUnexpected = E.singleton (Tokens $ nes h)-            , errorExpected   = E.singleton (Tokens $ nes span)-            , errorCustom     = E.empty } )--pSpan :: Span -> CustomParser Span-pSpan span = token testToken (Just span)-  where-    f = E.singleton . Tokens . nes-    testToken x =-      if spanBody x == spanBody span-        then Right span-        else Left (f x, f span , E.empty)--prop_cst_tokens :: State [Span] -> [Span] -> Property-prop_cst_tokens st' ts =-  forAll (incCoincidence st' ts) $ \st@State {..} ->-  let-    p = tokens compareTokens ts :: CustomParser [Span]-    compareTokens x y = spanBody x == spanBody y-    updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth-    ts' = NE.fromList ts-    il = length . takeWhile id $ zipWith compareTokens stateInput ts-    tl = length ts-    consumed = take il stateInput-    (apos, npos) =-      let (pos:|z) = statePos-      in ( spanStart (head stateInput) :| z-         , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z )-    r | null ts = (st, Right [])-      | null stateInput =-        ( st-        , Left ParseError-          { errorPos        = statePos-          , errorUnexpected = E.singleton EndOfInput-          , errorExpected   = E.singleton (Tokens ts')-          , errorCustom     = E.empty } )-      | il == tl =-        ( st { statePos   = npos-             , stateInput = drop (length ts) stateInput }-        , Right consumed )-      | otherwise =-        ( st { statePos = apos }-        , Left ParseError-          { errorPos        = apos-          , errorUnexpected = E.singleton-            (Tokens . NE.fromList $ take (il + 1) stateInput)-          , errorExpected   = E.singleton (Tokens ts')-          , errorCustom     = E.empty } )-  in runParser' p st === r--incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])-incCoincidence st ts = do-  n <- getSmall <$> arbitrary-  let (pre, post) = splitAt n (stateInput st)-      pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts-  return st { stateInput = pre' ++ post }---- Functor instance--prop_functor :: Integer -> Integer -> Property-prop_functor n m =-  ((+ m) <$> return n) /=\ n + m .&&. ((* n) <$> return m) /=\ n * m---- Applicative instance--prop_applicative_0 :: Integer -> Integer -> Property-prop_applicative_0 n m = ((+) <$> pure n <*> pure m) /=\ n + m--prop_applicative_1 :: Char -> Char -> Property-prop_applicative_1 a b = a /= b ==> checkParser p r s-  where-    p = pure toUpper <*> (char a >> char a)-    r = posErr 1 s [utok b, etok a]-    s = [a,b]--prop_applicative_2 :: Integer -> Integer -> Property-prop_applicative_2 n m = (pure n *> pure m) /=\ m--prop_applicative_3 :: Integer -> Integer -> Property-prop_applicative_3 n m = (pure n <* pure m) /=\ n---- Alternative instance--prop_alternative_0 :: Integer -> Property-prop_alternative_0 n = (empty <|> return n) /=\ n--prop_alternative_1 :: String -> String -> Property-prop_alternative_1 s0 s1-  | s0 == s1 = checkParser p (Right s0) s1-  | null s0  = checkParser p (posErr 0 s1 [utok (head s1), eeof]) s1-  | s0 `isPrefixOf` s1 =-      checkParser p (posErr s0l s1 [utok (s1 !! s0l), eeof]) s1-  | otherwise = checkParser p (Right s0) s0 .&&. checkParser p (Right s1) s1-    where p   = string s0 <|> string s1-          s0l = length s0--prop_alternative_2 :: Char -> Char -> Char -> Bool -> Property-prop_alternative_2 a b c l = checkParser p r s-  where p = char a <|> (char b >> char a)-        r | l         = Right a-          | a == b    = posErr 1 s [utok c, eeof]-          | a == c    = Right a-          | otherwise = posErr 1 s [utok c, etok a]-        s = if l then [a] else [b,c]--prop_alternative_3 :: Property-prop_alternative_3 = checkParser p r s-  where p  = asum [empty, string ">>>", empty, return "foo"] <?> "bar"-        p' = bsum [empty, string ">>>", empty, return "foo"] <?> "bar"-        bsum = foldl (<|>) empty-        r = simpleParse p' s-        s = ">>"--prop_alternative_4 :: NonNegative Int -> NonNegative Int-                   -> NonNegative Int -> Property-prop_alternative_4 a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (++) <$> many (char 'a') <*> many (char 'b')-        r | null s = Right s-          | c > 0  = posErr (a + b) s $ [utok 'c', etok 'b', eeof]-                     ++ [etok 'a' | b == 0]-          | otherwise = Right s-        s = abcRow a b c--prop_alternative_5 :: NonNegative Int -> NonNegative Int-                   -> NonNegative Int -> Property-prop_alternative_5 a' b' c' = checkParser p r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = (++) <$> some (char 'a') <*> some (char 'b')-        r | null s = posErr 0 s [ueof, etok 'a']-          | a == 0 = posErr 0 s [utok (head s), etok 'a']-          | b == 0 = posErr a s $ [etok 'a', etok 'b'] ++-                     if c > 0 then [utok 'c'] else [ueof]-          | c > 0 = posErr (a + b) s [utok 'c', etok 'b', eeof]-          | otherwise = Right s-        s = abcRow a b c--prop_alternative_6 :: Bool -> Bool -> Bool -> Property-prop_alternative_6 a b c = checkParser p r s-  where p = f <$> optional (char 'a') <*> optional (char 'b')-        f x y = maybe "" (:[]) x ++ maybe "" (:[]) y-        r | c = posErr ab s $ [utok 'c', eeof] ++-                [etok 'a' | not a && not b] ++ [etok 'b' | not b]-          | otherwise = Right s-        s = abcRow a b c-        ab = fromEnum a + fromEnum b---- Monad instance--prop_monad_0 :: Integer -> Property-prop_monad_0 n = checkParser (return n) (Right n) ""--prop_monad_1 :: Char -> Char -> Maybe Char -> Property-prop_monad_1 a b c = checkParser p r s-  where p = char a >> char b-        r = simpleParse (char a *> char b) s-        s = a : b : maybeToList c--prop_monad_2 :: Char -> Char -> Maybe Char -> Property-prop_monad_2 a b c = checkParser p r s-  where p = char a >>= \x -> char b >> return x-        r = simpleParse (char a <* char b) s-        s = a : b : maybeToList c--prop_monad_3 :: String -> Property-prop_monad_3 msg = checkParser p r s-  where p = fail msg :: Parser ()-        r = posErr 0 s [cstm (DecFail msg)]-        s = ""--prop_monad_left_id :: Integer -> Integer -> Property-prop_monad_left_id a b = (return a >>= f) !=! f a-  where f x = return $ x + b--prop_monad_right_id :: Integer -> Property-prop_monad_right_id a = (m >>= return) !=! m-  where m = return a--prop_monad_assoc :: Integer -> Integer -> Integer -> Property-prop_monad_assoc a b c = ((m >>= f) >>= g) !=! (m >>= (\x -> f x >>= g))-  where m = return a-        f x = return $ x + b-        g x = return $ x + c---- MonadIO instance--prop_monad_io :: Integer -> Property-prop_monad_io n = ioProperty (liftM (=== Right n) (runParserT p "" ""))-  where p = liftIO (return n) :: ParsecT Dec String IO Integer---- MonadReader instance--prop_monad_reader_ask :: Integer -> Property-prop_monad_reader_ask a = runReader (runParserT p "" "") a === Right a-  where p = ask :: ParsecT Dec String (Reader Integer) Integer--prop_monad_reader_local :: Integer -> Integer -> Property-prop_monad_reader_local a b =-  runReader (runParserT p "" "") a === Right (a + b)-  where p = local (+ b) ask :: ParsecT Dec String (Reader Integer) Integer---- MonadState instance--prop_monad_state_get :: Integer -> Property-prop_monad_state_get a = L.evalState (runParserT p "" "") a === Right a-  where p = L.get :: ParsecT Dec String (L.State Integer) Integer--prop_monad_state_put :: Integer -> Integer -> Property-prop_monad_state_put a b = L.execState (runParserT p "" "") a === b-  where p = L.put b :: ParsecT Dec String (L.State Integer) ()---- MonadCont instance--prop_monad_cont :: Integer -> Integer -> Property-prop_monad_cont a b = runCont (runParserT p "" "") id === Right (max a b)-  where p :: ParsecT Dec String-             (Cont (Either (ParseError Char Dec) Integer)) Integer-        p = do x <- callCC $ \e -> when (a > b) (e a) >> return b-               return x---- MonadError instance--prop_monad_error_throw :: Integer -> Integer -> Property-prop_monad_error_throw a b = runExcept (runParserT p "" "") === Left a-  where p :: ParsecT Dec String (Except Integer) Integer-        p = throwError a >> return b--prop_monad_error_catch :: Integer -> Integer -> Property-prop_monad_error_catch a b =-  runExcept (runParserT p "" "") === Right (Right $ a + b)-  where p :: ParsecT Dec String (Except Integer) Integer-        p = (throwError a >> return b) `catchError` handler-        handler e = return (e + b)---- Primitive combinators--prop_unexpected :: ErrorItem Char -> Property-prop_unexpected item = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = unexpected item-        r = posErr 0 s [Unexpected item]-        s = ""--prop_failure-  :: Set (ErrorItem Char)-  -> Set (ErrorItem Char)-  -> Set Dec-  -> Property-prop_failure us ps xs = checkParser' p r s-  where p :: (MonadParsec Dec s m, Token s ~ Char) => m String-        p = failure us ps xs-        r = Left ParseError-          { errorPos        = nes (initialPos "")-          , errorUnexpected = us-          , errorExpected   = ps-          , errorCustom     = xs }-        s = ""--prop_label :: NonNegative Int -> NonNegative Int-           -> NonNegative Int -> String -> Property-prop_label a' b' c' l = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = (++) <$> many (char 'a') <*> (many (char 'b') <?> l)-        r | null s = Right s-          | c > 0 = posErr (a + b) s $ [utok 'c', eeof]-            ++ [etok 'a' | b == 0]-            ++ (if null l-                  then []-                  else [if b == 0-                         then elabel l-                         else elabel ("rest of " ++ l)])-          | otherwise = Right s-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_hidden_0 :: NonNegative Int -> NonNegative Int-              -> NonNegative Int -> Property-prop_hidden_0 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = (++) <$> many (char 'a') <*> hidden (many (char 'b'))-        r | null s = Right s-          | c > 0  = posErr (a + b) s $ [utok 'c', eeof]-                     ++ [etok 'a' | b == 0]-          | otherwise = Right s-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_hidden_1 :: NonEmptyList Char -> String -> Property-prop_hidden_1 c' s = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m (Maybe String)-        p = optional (hidden $ string c)-        r | null s           = Right Nothing-          | c == s           = Right (Just s)-          | c `isPrefixOf` s = posErr cn s [utok (s !! cn), eeof]-          | otherwise        = posErr 0 s [utok (head s), eeof]-        c = getNonEmpty c'-        cn = length c--prop_try :: Char -> Char -> Char -> Property-prop_try pre ch1 ch2 = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = try (sequence [char pre, char ch1])-          <|> sequence [char pre, char ch2]-        r = posErr 1 s [ueof, etok ch1, etok ch2]-        s = [pre]--prop_lookAhead_0 :: Bool -> Bool -> Bool -> Property-prop_lookAhead_0 a b c = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = do-          l <- lookAhead (oneOf "ab" <?> "label")-          guard (l == h)-          char 'a'-        h = head s-        r | null s = posErr 0 s [ueof, elabel "label"]-          | s == "a" = Right 'a'-          | h == 'b' = posErr 0 s [utok 'b', etok 'a']-          | h == 'c' = posErr 0 s [utok 'c', elabel "label"]-          | otherwise  = posErr 1 s [utok (s !! 1), eeof]-        s = abcRow a b c--prop_lookAhead_1 :: String -> Property-prop_lookAhead_1 s = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = lookAhead (some letterChar) >> fail emsg-        h = head s-        r | null s     = posErr 0 s [ueof, elabel "letter"]-          | isLetter h = posErr 0 s [cstm (DecFail emsg)]-          | otherwise  = posErr 0 s [utok h, elabel "letter"]-        emsg = "ops!"--prop_lookAhead_2 :: Bool -> Bool -> Bool -> Property-prop_lookAhead_2 a b c = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = lookAhead (some (char 'a')) >> char 'b'-        r | null s    = posErr 0 s [ueof, etok 'a']-          | a         = posErr 0 s [utok 'a', etok 'b']-          | otherwise = posErr 0 s [utok (head s), etok 'a']-        s = abcRow a b c--case_lookAhead_3 :: Assertion-case_lookAhead_3 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = lookAhead (char 'a' *> fail emsg)-        r = posErr 1 s [cstm (DecFail emsg)]-        emsg = "ops!"-        s = "abc"--prop_notFollowedBy_0 :: NonNegative Int -> NonNegative Int-                     -> NonNegative Int -> Property-prop_notFollowedBy_0 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = many (char 'a') <* notFollowedBy (char 'b') <* many (char 'c')-        r | b > 0     = posErr a s [utok 'b', etok 'a']-          | otherwise = Right (replicate a 'a')-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int-                     -> NonNegative Int -> Property-prop_notFollowedBy_1 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = many (char 'a')-          <* (notFollowedBy . notFollowedBy) (char 'c')-          <* many (char 'c')-        r | b == 0 && c > 0 = Right (replicate a 'a')-          | b > 0           = posErr a s [utok 'b', etok 'a']-          | otherwise       = posErr a s [ueof, etok 'a']-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--prop_notFollowedBy_2 :: NonNegative Int -> NonNegative Int-                     -> NonNegative Int -> Property-prop_notFollowedBy_2 a' b' c' = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = many (char 'a') <* notFollowedBy eof <* many anyChar-        r | b > 0 || c > 0 = Right (replicate a 'a')-          | otherwise      = posErr a s [ueof, etok 'a']-        s = abcRow a b c-        [a,b,c] = getNonNegative <$> [a',b',c']--case_notFollowedBy_3a :: Assertion-case_notFollowedBy_3a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = notFollowedBy (char 'a' *> char 'c')-        r = Right ()-        s = "ab"--case_notFollowedBy_3b :: Assertion-case_notFollowedBy_3b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = notFollowedBy (char 'a' *> char 'd') <* char 'c'-        r = posErr 0 s [utok 'a', etok 'c']-        s = "ab"--case_notFollowedBy_4a :: Assertion-case_notFollowedBy_4a = checkCase' p r s-  where p :: MonadParsec e s m => m ()-        p = notFollowedBy mzero-        r = Right ()-        s = "ab"--case_notFollowedBy_4b :: Assertion-case_notFollowedBy_4b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m ()-        p = notFollowedBy mzero <* char 'c'-        r = posErr 0 s [utok 'a', etok 'c']-        s = "ab"--prop_withRecovery_0-  :: NonNegative Int-  -> NonNegative Int-  -> NonNegative Int-  -> Property-prop_withRecovery_0 a' b' c' = checkParser' p r s-  where-    p :: (MonadParsec Dec s m, Token s ~ Char)-      => m (Either (ParseError Char Dec) String)-    p = let g = count' 1 3 . char in v <$>-      withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'-    v (Right x) y = Right (x ++ y)-    v (Left  m) _ = Left m-    r | a == 0 && b == 0 && c == 0 = posErr 0 s [ueof, etok 'a']-      | a == 0 && b == 0 && c >  3 = posErr 0 s [utok 'c', etok 'a']-      | a == 0 && b == 0           = posErr 0 s [utok 'c', etok 'a']-      | a == 0 && b >  3           = posErr 3 s [utok 'b', etok 'a', etok 'c']-      | a == 0 &&           c == 0 = posErr b s [ueof, etok 'a', etok 'c']-      | a == 0 &&           c >  3 = posErr (b + 3) s [utok 'c', eeof]-      | a == 0                     = Right (posErr 0 s [utok 'b', etok 'a'])-      | a >  3                     = posErr 3 s [utok 'a', etok 'c']-      |           b == 0 && c == 0 = posErr a s $ [ueof, etok 'c'] ++ ma-      |           b == 0 && c >  3 = posErr (a + 3) s [utok 'c', eeof]-      |           b == 0           = Right (Right s)-      | otherwise                  = posErr a s $ [utok 'b', etok 'c'] ++ ma-    ma = [etok 'a' | a < 3]-    s = abcRow a b c-    [a,b,c] = getNonNegative <$> [a',b',c']--case_withRecovery_1 :: Assertion-case_withRecovery_1 = checkCase' p r s-  where p :: MonadParsec e s m => m String-        p = withRecovery (const $ return "bar") (return "foo")-        r = Right "foo"-        s = "abc"--case_withRecovery_2 :: Assertion-case_withRecovery_2 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (\_ -> char 'a' *> mzero) (string "cba")-        r = posErr 0 s [utoks "a", etoks "cba"]-        s = "abc"--case_withRecovery_3a :: Assertion-case_withRecovery_3a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ return "abd") (string "cba")-        r = Right "abd"-        s = "abc"--case_withRecovery_3b :: Assertion-case_withRecovery_3b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ return "abd") (string "cba") <* char 'd'-        r = posErr 0 s [utok 'a', etoks "cba", etok 'd']-        s = "abc"--case_withRecovery_4a :: Assertion-case_withRecovery_4a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ string "bc") (char 'a' *> mzero)-        r = Right "bc"-        s = "abc"--case_withRecovery_4b :: Assertion-case_withRecovery_4b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ string "bc")-          (char 'a' *> char 'd' *> pure "foo") <* char 'f'-        r = posErr 3 s [ueof, etok 'f']-        s = "abc"--case_withRecovery_5 :: Assertion-case_withRecovery_5 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (\_ -> char 'b' *> fail emsg) (char 'a' *> fail emsg)-        r = posErr 1 s [cstm (DecFail emsg)]-        emsg = "ops!"-        s = "abc"--case_withRecovery_6a :: Assertion-case_withRecovery_6a = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m String-        p = withRecovery (const $ return "abd") (char 'a' *> mzero)-        r = Right "abd"-        s = "abc"--case_withRecovery_6b :: Assertion-case_withRecovery_6b = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = withRecovery (const $ return 'g') (char 'a' *> char 'd') <* char 'f'-        r = posErr 1 s [utok 'b', etok 'd', etok 'f']-        s = "abc"--case_withRecovery_7 :: Assertion-case_withRecovery_7 = checkCase' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = withRecovery (const mzero) (char 'a' *> char 'd')-        r = posErr 1 s [utok 'b', etok 'd']-        s = "abc"--case_eof :: Assertion-case_eof = checkCase' eof (Right ()) ""--prop_token :: Maybe Char -> String -> Property-prop_token mtok s = checkParser' p r s-  where p :: (MonadParsec e s m, Token s ~ Char) => m Char-        p = token testChar mtok-        testChar x = if isLetter x-          then Right x-          else Left (E.singleton (Tokens $ nes x), E.empty, E.empty)-        h = head s-        r | null s = posErr 0 s $ ueof : maybeToList (etok <$> mtok)-          | isLetter h && length s == 1 = Right (head s)-          | isLetter h && length s > 1 = posErr 1 s [utok (s !! 1), eeof]-          | otherwise = posErr 0 s [utok h]--prop_tokens_0 :: String -> String -> Property-prop_tokens_0 a = checkString (tokens (==) a) a (==)--prop_tokens_1 :: String -> String -> String -> Property-prop_tokens_1 pre post post' =-  not (post `isPrefixOf` post') ==>-  (leftover === "" .||. leftover === s)-  where p :: Parser String-        p = tokens (==) (pre ++ post)-        s = pre ++ post'-        st = stateFromInput s-        leftover = stateInput . fst $ runParser' p st---- Parser state combinators--prop_state_pos :: State String -> SourcePos -> Property-prop_state_pos st pos = runParser' p st === r-  where p = (setPosition pos >> getPosition) :: Parser SourcePos-        r = (f st pos, Right pos)-        f (State s (_:|xs) w) y = State s (y:|xs) w--prop_state_pushPosition :: State String -> SourcePos -> Property-prop_state_pushPosition st pos = fst (runParser' p st) === r-  where p = pushPosition pos :: Parser ()-        r = st { statePos = NE.cons pos (statePos st) }--prop_state_popPosition :: State String -> Property-prop_state_popPosition st = fst (runParser' p st) === r-  where p = popPosition :: Parser ()-        r = st { statePos = fromMaybe pos (snd (NE.uncons pos)) }-        pos = statePos st--prop_state_input :: String -> Property-prop_state_input s = p /=\ s-  where p = do-          st0    <- getInput-          guard (null st0)-          setInput s-          result <- string s-          st1    <- getInput-          guard (null st1)-          return result--prop_state_tab :: Pos -> Property-prop_state_tab w = p /=\ w-  where p = setTabWidth w >> getTabWidth--prop_state :: State String -> State String -> Property-prop_state s1 s2 = checkParser' p r s-  where p :: MonadParsec Dec String m => m (State String)-        p = do-          st <- getParserState-          guard (st == State s (nes $ initialPos "") defaultTabWidth)-          setParserState s1-          updateParserState (f s2)-          liftM2 const getParserState (setInput "")-        f (State s1' pos w) (State s2' _ _) = State (max s1' s2' ) pos w-        r = Right (f s2 s1)-        s = ""---- Running a parser--prop_parseMaybe :: String -> String -> Property-prop_parseMaybe s s' = parseMaybe p s === r-  where p = string s' :: Parser String-        r = if s == s' then Just s else Nothing--prop_runParser' :: State String -> String -> Property-prop_runParser' st s = runParser' p st === r-  where p = string s-        r = emulateStrParsing st s--prop_runParserT' :: State String -> String -> Property-prop_runParserT' st s = runIdentity (runParserT' p st) === r-  where p = string s-        r = emulateStrParsing st s--emulateStrParsing-  :: State String-  -> String-  -> (State String, Either (ParseError Char Dec) String)-emulateStrParsing st@(State i (pos:|z) t) s =-  if l == length s-    then (State (drop l i) (updatePosString t pos s :| z) t, Right s)-    else (st, posErr' (pos:|z) (etoks s : [utoks (take (l + 1) i)]))-  where l = length (takeWhile id $ zipWith (==) s i)---- Additional tests to check returned state on failure--prop_stOnFail_0 :: Positive Int -> Positive Int -> Property-prop_stOnFail_0 na' nb' = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State "" (errorPos x) defaultTabWidth-        na = getPositive na'-        nb = getPositive nb'-        p = try (many (char 'a') <* many (char 'b') <* char 'c')-          <|> (many (char 'a') <* char 'c')-        r = posErr (na + nb) s [etok 'b', etok 'c', ueof]-        s = replicate na 'a' ++ replicate nb 'b'--prop_stOnFail_1 :: Positive Int -> Pos -> Property-prop_stOnFail_1 na' t = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State "" (errorPos x) t-        na = getPositive na'-        p = many (char 'a') <* setTabWidth t <* fail emsg-        r = posErr na s [cstm (DecFail emsg)]-        s = replicate na 'a'-        emsg = "failing now!"--prop_stOnFail_2 :: String -> Char -> Property-prop_stOnFail_2 s' ch = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State [ch] (errorPos x) defaultTabWidth-        r = posErr (length s') s [utok ch, eeof]-        p = string s' <* eof-        s = s' ++ [ch]--prop_stOnFail_3 :: String -> Property-prop_stOnFail_3 s = runParser' p (stateFromInput s) === (i, r)-  where i = let (Left x) = r in State s (errorPos x) defaultTabWidth-        r = posErr 0 s [if null s then ueof else utok (head s)]-        p = notFollowedBy (string s)--stateFromInput :: s -> State s-stateFromInput s = State s (nes $ initialPos "") defaultTabWidth---- ReaderT instance of MonadParsec--prop_ReaderT_try :: Char -> Char -> Char -> Property-prop_ReaderT_try pre ch1 ch2 = checkParser (runReaderT p (s1, s2)) r s-  where s1 = pre : [ch1]-        s2 = pre : [ch2]-        getS1 = asks fst-        getS2 = asks snd-        p = try (g =<< getS1) <|> (g =<< getS2)-        g = sequence . fmap char-        r = posErr 1 s [ueof, etok ch1, etok ch2]-        s = [pre]--prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int-                           -> NonNegative Int -> Property-prop_ReaderT_notFollowedBy a' b' c' = checkParser (runReaderT p 'a') r s-  where [a,b,c] = getNonNegative <$> [a',b',c']-        p = many (char =<< ask) <* notFollowedBy eof <* many anyChar-        r | b > 0 || c > 0 = Right (replicate a 'a')-          | otherwise      = posErr a s [ueof, etok 'a']-        s = abcRow a b c---- StateT instance of MonadParsec--prop_StateT_alternative :: Integer -> Property-prop_StateT_alternative n =-  checkParser (L.evalStateT p 0) (Right n) "" .&&.-  checkParser (S.evalStateT p' 0) (Right n) ""-  where p  = L.put n >> ((L.modify (* 2) >>-                          void (string "xxx")) <|> return ()) >> L.get-        p' = S.put n >> ((S.modify (* 2) >>-                          void (string "xxx")) <|> return ()) >> S.get--prop_StateT_lookAhead :: Integer -> Property-prop_StateT_lookAhead n =-  checkParser (L.evalStateT p 0) (Right n) "" .&&.-  checkParser (S.evalStateT p' 0) (Right n) ""-  where p  = L.put n >> lookAhead (L.modify (* 2) >> eof) >> L.get-        p' = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get--prop_StateT_notFollowedBy :: Integer -> Property-prop_StateT_notFollowedBy n = checkParser (L.runStateT p 0) r "abx" .&&.-                              checkParser (S.runStateT p' 0) r "abx"-  where p = do-          L.put n-          let notEof = notFollowedBy (L.modify (* 2) >> eof)-          some (try (anyChar <* notEof)) <* char 'x'-        p' = do-          S.put n-          let notEof = notFollowedBy (S.modify (* 2) >> eof)-          some (try (anyChar <* notEof)) <* char 'x'-        r = Right ("ab", n)---- WriterT instance of MonadParsec--prop_WriterT :: String -> String -> Property-prop_WriterT pre post =-  checkParser (L.runWriterT p) r "abx" .&&.-  checkParser (S.runWriterT p') r "abx"-  where logged_letter  = letterChar >>= \x -> L.tell [x] >> return x-        logged_letter' = letterChar >>= \x -> L.tell [x] >> return x-        logged_eof     = eof >> L.tell "EOF"-        logged_eof'    = eof >> L.tell "EOF"-        p = do-          L.tell pre-          cs <- L.censor (fmap toUpper) $-                  some (try (logged_letter <* notFollowedBy logged_eof))-          L.tell post-          void logged_letter-          return cs-        p' = do-          L.tell pre-          cs <- L.censor (fmap toUpper) $-                  some (try (logged_letter' <* notFollowedBy logged_eof'))-          L.tell post-          void logged_letter'-          return cs-        r = Right ("ab", pre ++ "AB" ++ post ++ "x")--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}

@@ -0,0 +1,11 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ >= 708+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}+#else++module Spec (main) where++main :: IO ()+main = return ()+#endif

@@ -0,0 +1,376 @@+-- |+-- Module      :  Test.Hspec.Megaparsec+-- Copyright   :  © 2016 Mark Karpov+-- License     :  BSD 3 clause+--+-- Maintainer  :  Mark Karpov <markkarpov@openmailbox.org>+-- Stability   :  experimental+-- Portability :  portable+--+-- Utility functions for testing Megaparsec parsers with Hspec.++{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies        #-}++module Test.Hspec.Megaparsec+  ( -- * Basic expectations+    shouldParse+  , parseSatisfies+  , shouldSucceedOn+  , shouldFailOn+    -- * Testing of error messages+  , shouldFailWith+    -- * Error message construction+    -- $errmsg+  , err+  , posI+  , posN+  , EC+  , utok+  , utoks+  , ulabel+  , ueof+  , etok+  , etoks+  , elabel+  , eeof+  , cstm+    -- * Incremental parsing+  , failsLeaving+  , succeedsLeaving+  , initialState )+where++import Control.Monad (unless)+import Data.Data (Data)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy+import Data.Semigroup+import Data.Set (Set)+import Data.Typeable (Typeable)+import GHC.Generics+import Test.Hspec.Expectations+import Text.Megaparsec+import Text.Megaparsec.Pos (defaultTabWidth)+import qualified Data.List.NonEmpty as NE+import qualified Data.Set           as E++----------------------------------------------------------------------------+-- Basic expectations++-- | Create an expectation by saying what the result should be.+--+-- > parse letterChar "" "x" `shouldParse` 'x'++shouldParse :: (Ord t, ShowToken t, ShowErrorComponent e, Eq a, Show a)+  => Either (ParseError t e) a+     -- ^ Result of parsing as returned by function like 'parse'+  -> a                 -- ^ Desired result+  -> Expectation+r `shouldParse` v = case r of+  Left e -> expectationFailure $ "expected: " ++ show v +++    "\nbut parsing failed with error:\n" ++ showParseError e+  Right x -> unless (x == v) . expectationFailure $+    "expected: " ++ show v ++ "\nbut got: " ++ show x++-- | Create an expectation by saying that the parser should successfully+-- parse a value and that the value should satisfy some predicate.+--+-- > parse (many punctuationChar) "" "?!!" `parseSatisfies` ((== 3) . length)++parseSatisfies :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)+  => Either (ParseError t e) a+     -- ^ Result of parsing as returned by function like 'parse'+  -> (a -> Bool)       -- ^ Predicate+  -> Expectation+r `parseSatisfies` p = case r of+  Left e -> expectationFailure $+    "expected a parsed value to check against the predicate" +++    "\nbut parsing failed with error:\n" ++ showParseError e+  Right x -> unless (p x) . expectationFailure $+    "the value did not satisfy the predicate: " ++ show x++-- | Check that a parser fails on some given input.+--+-- > parse (char 'x') "" `shouldFailOn` "a"++shouldFailOn :: Show a+  => (s -> Either (ParseError t e) a)+     -- ^ Parser that takes stream and produces result or error message+  -> s                 -- ^ Input that the parser should fail on+  -> Expectation+p `shouldFailOn` s = shouldFail (p s)++-- | Check that a parser succeeds on some given input.+--+-- > parse (char 'x') "" `shouldSucceedOn` "x"++shouldSucceedOn :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)+  => (s -> Either (ParseError t e) a)+     -- ^ Parser that takes stream and produces result or error message+  -> s                 -- ^ Input that the parser should succeed on+  -> Expectation+p `shouldSucceedOn` s = shouldSucceed (p s)++----------------------------------------------------------------------------+-- Testing of error messages++-- | Create an expectation that parser should fail producing certain+-- 'ParseError'. Use the 'err' function from this module to construct a+-- 'ParseError' to compare with.+--+-- > parse (char 'x') "" "b" `shouldFailWith` err posI (utok 'b' <> etok 'x')++shouldFailWith :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)+  => Either (ParseError t e) a+  -> ParseError t e+  -> Expectation+r `shouldFailWith` e = case r of+  Left e' -> unless (e == e') . expectationFailure $+    "the parser is expected to fail with:\n" ++ showParseError e +++    "but it failed with:\n" ++ showParseError e'+  Right v -> expectationFailure $+    "the parser is expected to fail, but it parsed: " ++ show v++----------------------------------------------------------------------------+-- Error message construction++-- $errmsg When you wish to test error message on failure, the need to+-- construct a error message for comparison arises. These helpers allow to+-- construct virtually any sort of error message easily.++-- | Assemble a 'ParseErorr' from source position and @'EC' t e@ value. To+-- create source position, two helpers are available: 'posI' and 'posN'.+-- @'EC' t e@ is a monoid and can be built from primitives provided by this+-- module, see below.+--+-- @since 0.3.0++err+  :: NonEmpty SourcePos -- ^ 'ParseError' position+  -> EC t e             -- ^ Error components+  -> ParseError t e     -- ^ Resulting 'ParseError'+err pos (EC u e c) = ParseError pos u e c++-- | Initial source position with empty file name.+--+-- @since 0.3.0++posI :: NonEmpty SourcePos+posI = initialPos "" :| []++-- | @posN n s@ returns source position achieved by applying 'updatePos'+-- method corresponding to type of stream @s@ @n@ times.+--+-- @since 0.3.0++posN :: forall s n. (Stream s, Integral n)+  => n+  -> s+  -> NonEmpty SourcePos+posN n see = f (initialPos "") see n :| []+  where+    f p s !i =+      if i > 0+        then case uncons s of+          Nothing -> p+          Just (t,s') ->+            let p' = snd $ updatePos (Proxy :: Proxy s) defaultTabWidth p t+            in f p' s' (i - 1)+        else p++-- | Auxiliary type for construction of 'ParseError's. Note that it's a+-- monoid.+--+-- @since 0.3.0++data EC t e = EC+  { ecUnexpected :: Set (ErrorItem t) -- ^ Unexpected items+  , ecExpected   :: Set (ErrorItem t) -- ^ Expected items+  , _ecCustom    :: Set e             -- ^ Custom items+  } deriving (Eq, Data, Typeable, Generic)++instance (Ord t, Ord e) => Semigroup (EC t e) where+  (EC u0 e0 c0) <> (EC u1 e1 c1) =+    EC (E.union u0 u1) (E.union e0 e1) (E.union c0 c1)++instance (Ord t, Ord e) => Monoid (EC t e) where+  mempty  = EC E.empty E.empty E.empty+  mappend = (<>)++-- | Construct “unexpected token” error component.+--+-- @since 0.3.0++utok :: (Ord t, Ord e) => t -> EC t e+utok t = mempty { ecUnexpected = (E.singleton . Tokens . nes) t }++-- | Construct “unexpected tokens” error component. Empty string produces+-- 'EndOfInput'.+--+-- @since 0.3.0++utoks :: (Ord t, Ord e) => [t] -> EC t e+utoks t = mempty { ecUnexpected = (E.singleton . canonicalizeTokens) t }++-- | Construct “unexpected label” error component. Do not use with empty+-- strings (for empty strings it's bottom).+--+-- @since 0.3.0++ulabel :: (Ord t, Ord e) => String -> EC t e+ulabel l = mempty { ecUnexpected = (E.singleton . Label . NE.fromList) l }++-- | Construct “unexpected end of input” error component.+--+-- @since 0.3.0++ueof :: (Ord t, Ord e) => EC t e+ueof = mempty { ecUnexpected = E.singleton EndOfInput }++-- | Construct “expected token” error component.+--+-- @since 0.3.0++etok :: (Ord t, Ord e) => t -> EC t e+etok t = mempty { ecExpected = (E.singleton . Tokens . nes) t }++-- | Construct “expected tokens” error component. Empty string produces+-- 'EndOfInput'.+--+-- @since 0.3.0++etoks :: (Ord t, Ord e) => [t] -> EC t e+etoks t = mempty { ecExpected = (E.singleton . canonicalizeTokens) t }++-- | Construct “expected label” error component. Do not use with empty+-- strings.+--+-- @since 0.3.0++elabel :: (Ord t, Ord e) => String -> EC t e+elabel l = mempty { ecExpected = (E.singleton . Label . NE.fromList) l }++-- | Construct “expected end of input” error component.+--+-- @since 0.3.0++eeof :: (Ord t, Ord e) => EC t e+eeof = mempty { ecExpected = E.singleton EndOfInput }++-- | Construct custom error component.+--+-- @since 0.3.0++cstm :: e -> EC t e+cstm e = EC E.empty E.empty (E.singleton e)++----------------------------------------------------------------------------+-- Incremental parsing++-- | Check that a parser fails and leaves certain part of input+-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''+-- that support incremental parsing.+--+-- > runParser' (many (char 'x') <* eof) (initialState "xxa")+-- >   `failsLeaving` "a"+--+-- See also: 'initialState'.++failsLeaving :: (Show a, Eq s, Show s, Stream s)+  => (State s, Either (ParseError (Token s) e) a)+     -- ^ Parser that takes stream and produces result along with actual+     -- state information+  -> s                 -- ^ Part of input that should be left unconsumed+  -> Expectation+(st,r) `failsLeaving` s =+  shouldFail r >> checkUnconsumed s (stateInput st)++-- | Check that a parser succeeds and leaves certain part of input+-- unconsumed. Use it with functions like 'runParser'' and 'runParserT''+-- that support incremental parsing.+--+-- > runParser' (many (char 'x')) (initialState "xxa")+-- >   `succeedsLeaving` "a"+--+-- See also: 'initialState'.++succeedsLeaving :: ( ShowToken (Token s)+                   , ShowErrorComponent e+                   , Show a+                   , Eq s+                   , Show s+                   , Stream s )+  => (State s, Either (ParseError (Token s) e) a)+     -- ^ Parser that takes stream and produces result along with actual+     -- state information+  -> s                 -- ^ Part of input that should be left unconsumed+  -> Expectation+(st,r) `succeedsLeaving` s =+  shouldSucceed r >> checkUnconsumed s (stateInput st)++-- | Given input for parsing, construct initial state for parser (that is,+-- with empty file name, default tab width and position at 1 line and 1+-- column).++initialState :: s -> State s+initialState s = State s (initialPos "" :| []) defaultTabWidth++----------------------------------------------------------------------------+-- Helpers++-- | Expectation that argument is result of a failed parser.++shouldFail :: Show a => Either (ParseError t e) a -> Expectation+shouldFail r = case r of+  Left _ -> return ()+  Right v -> expectationFailure $+    "the parser is expected to fail, but it parsed: " ++ show v++-- | Expectation that argument is result of a succeeded parser.++shouldSucceed :: (Ord t, ShowToken t, ShowErrorComponent e, Show a)+  => Either (ParseError t e) a -> Expectation+shouldSucceed r = case r of+  Left e -> expectationFailure $+    "the parser is expected to succeed, but it failed with:\n" +++    showParseError e+  Right _ -> return ()++-- | Compare two streams for equality and in the case of mismatch report it.++checkUnconsumed :: (Eq s, Show s, Stream s)+  => s                 -- ^ Expected unconsumed input+  -> s                 -- ^ Actual unconsumed input+  -> Expectation+checkUnconsumed e a = unless (e == a) . expectationFailure $+  "the parser is expected to leave unconsumed input: " ++ show e +++  "\nbut it left this: " ++ show a++-- | Render parse error in a way that is suitable for inserting it in test+-- suite report.++showParseError :: (Ord t, ShowToken t, ShowErrorComponent e)+  => ParseError t e -> String+showParseError = unlines . fmap ("  " ++) . lines . parseErrorPretty++-- | Make a singleton non-empty list from a value.++nes :: a -> NonEmpty a+nes x = x :| []+{-# INLINE nes #-}++-- | Construct appropriate 'ErrorItem' representation for given token+-- stream. Empty string produces 'EndOfInput'.++canonicalizeTokens :: [t] -> ErrorItem t+canonicalizeTokens ts =+  case NE.nonEmpty ts of+    Nothing -> EndOfInput+    Just xs -> Tokens xs

@@ -0,0 +1,185 @@+--+-- Tests for Megaparsec's expression parsers.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}++module Test.Hspec.Megaparsec.AdHoc+  ( -- * Helpers to run parsers+    prs+  , prs'+  , prs_+  , grs+  , grs'+    -- * Working with source position+  , updatePosString+  , pos1+  , nes+    -- * Other+  , abcRow+  , toFirstMismatch )+where++import Control.Monad+import Control.Monad.Reader+import Control.Monad.Trans.Identity+import Data.Foldable (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Test.Hspec+import Test.Hspec.Megaparsec+import Text.Megaparsec.Error+import Text.Megaparsec.Pos+import Text.Megaparsec.Prim+import qualified Control.Monad.State.Lazy    as L+import qualified Control.Monad.State.Strict  as S+import qualified Control.Monad.Writer.Lazy   as L+import qualified Control.Monad.Writer.Strict as S++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++----------------------------------------------------------------------------+-- Helpers to run parsers++-- | Apply parser to given input. This is a specialized version of 'parse'+-- that assumes empty file name.++prs+  :: Parsec Dec String a -- ^ Parser to run+  -> String            -- ^ Input for the parser+  -> Either (ParseError Char Dec) a -- ^ Result of parsing+prs p = parse p ""+{-# INLINE prs #-}++-- | Just like 'prs', but allows to inspect final state of the parser.++prs'+  :: Parsec Dec String a -- ^ Parser to run+  -> String            -- ^ Input for the parser+  -> (State String, Either (ParseError Char Dec) a) -- ^ Result of parsing+prs' p s = runParser' p (initialState s)+{-# INLINE prs' #-}++-- | Just like 'prs', but forces the parser to consume all input by adding+-- 'eof':+--+-- > prs_ p = parse (p <* eof) ""++prs_+  :: Parsec Dec String a -- ^ Parser to run+  -> String            -- ^ Input for the parser+  -> Either (ParseError Char Dec) a -- ^ Result of parsing+prs_ p = parse (p <* eof) ""+{-# INLINE prs_ #-}++-- | Just like 'prs', but interprets given parser as various monads (tries+-- all supported monads transformers in turn).++grs+  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run+  -> String            -- ^ Input for the parser+  -> (Either (ParseError Char Dec) a -> Expectation)+    -- ^ How to check result of parsing+  -> Expectation+grs p s r = do+  r (prs p s)+  r (prs (runIdentityT p)    s)+  r (prs (runReaderT   p ()) s)+  r (prs (L.evalStateT p ()) s)+  r (prs (S.evalStateT p ()) s)+  r (prs (evalWriterTL p)    s)+  r (prs (evalWriterTS p)    s)++-- | 'grs'' to 'grs' as 'prs'' to 'prs'.++grs'+  :: (forall m. MonadParsec Dec String m => m a) -- ^ Parser to run+  -> String            -- ^ Input for the parser+  -> ((State String, Either (ParseError Char Dec) a) -> Expectation)+    -- ^ How to check result of parsing+  -> Expectation+grs' p s r = do+  r (prs' p s)+  r (prs' (runIdentityT p)    s)+  r (prs' (runReaderT   p ()) s)+  r (prs' (L.evalStateT p ()) s)+  r (prs' (S.evalStateT p ()) s)+  r (prs' (evalWriterTL p)    s)+  r (prs' (evalWriterTS p)    s)++evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a+evalWriterTL = liftM fst . L.runWriterT+evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a+evalWriterTS = liftM fst . S.runWriterT++----------------------------------------------------------------------------+-- Working with source position++-- | A helper function that is used to advance 'SourcePos' given a 'String'.++updatePosString+  :: Pos               -- ^ Tab width+  -> SourcePos         -- ^ Initial position+  -> String            -- ^ 'String' — collection of tokens to process+  -> SourcePos         -- ^ Final position+updatePosString w = foldl' f+  where f p t = snd (defaultUpdatePos w p t)++-- | Position with minimal value.++pos1 :: Pos+pos1 = unsafePos 1++-- | Make a singleton non-empty list from a value.++nes :: a -> NonEmpty a+nes x = x :| []+{-# INLINE nes #-}++----------------------------------------------------------------------------+-- Other++-- | @abcRow a b c@ generates string consisting of character “a” repeated+-- @a@ times, character “b” repeated @b@ times, and character “c” repeated+-- @c@ times.++abcRow :: Int -> Int -> Int -> String+abcRow a b c = replicate a 'a' ++ replicate b 'b' ++ replicate c 'c'++-- | Given a comparing function, get prefix of one string till first+-- mismatch with another string (including first mismatching character).++toFirstMismatch+  :: (Char -> Char -> Bool) -- ^ Comparing function+  -> String            -- ^ First string+  -> String            -- ^ Second string+  -> String            -- ^ Resulting prefix+toFirstMismatch f str s = take (n + 1) s+  where n = length (takeWhile (uncurry f) (zip str s))

@@ -0,0 +1,450 @@+--+-- Tests for Megaparsec's character parsers.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP              #-}+{-# OPTIONS -fno-warn-orphans #-}++module Text.Megaparsec.CharSpec (spec) where++import Control.Monad+import Data.Char+import Data.List (partition, isPrefixOf)+import Data.Monoid ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Char+import Text.Megaparsec.Error+import Text.Megaparsec.Prim++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative+#endif++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 CSRF 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 posI+            (utoks s <> utok '\r' <> elabel "end of line")+    context "when input stream is '\\r'" $+      it "signals correct parse error" $+        prs eol "\r" `shouldFailWith` err posI+          (utok '\r' <> elabel "end of line")+    context "when stream does not begin with newline or CSRF sequence" $+      it "signals correct parse error" $+        property $ \ch s -> (ch `notElem` "\r\n") ==> do+          let s' = ch : s+          prs eol s' `shouldFailWith` err posI+            (utok ch <> elabel "end of line")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs eol "" `shouldFailWith` err posI+          (ueof <> elabel "end of line")++  describe "tab" $+    checkStrLit "tab" "\t" (pure <$> tab)++  describe "space" $+    it "consumes it 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 "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 "alphaNumChar" $+    checkCharPred "alphanumeric character" isAlphaNum alphaNumChar++  describe "printChar" $+    checkCharPred "printable character" isPrint printChar++  describe "digitChar" $+    checkCharRange "digit" ['0'..'9'] digitChar++  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" "" 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" $+#if MIN_VERSION_base(4,8,0)+    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦" symbolChar+#else+    checkCharRange "symbol" "<>$£`~|×÷^®°¸¯=¬+¤±¢¨´©¥¦§¶" symbolChar+#endif+  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 posI (utok 'б' <> elabel "Latin-1 character")+        prs' latin1Char "в" `failsLeaving`   "в"+    context "when stream is empty" $+      it "signals correct parse error" $+        prs latin1Char "" `shouldFailWith` err posI (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 posI (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 posI (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 posI (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 posI (ueof <> etok ch)++  describe "char'" $ do+    context "when stream begins with the character specified as argument" $+      it "parses the character" $+        property $ \ch s -> do+          let sl = toLower ch : s+              su = toUpper ch : s+          prs  (char' ch) sl `shouldParse`     toLower ch+          prs  (char' ch) su `shouldParse`     toUpper ch+          prs' (char' ch) sl `succeedsLeaving` s+          prs' (char' ch) su `succeedsLeaving` s+    context "when stream does not begin with the character specified as argument" $+      it "signals correct parse error" $+        property $ \ch ch' s -> toLower ch /= toLower ch' ==> do+          let s' = ch' : s+              ms = utok ch' <> etok (toLower ch) <> etok (toUpper ch)+          prs  (char' ch) s' `shouldFailWith` err posI ms+          prs' (char' ch) s' `failsLeaving`   s'+    context "when stream is empty" $+      it "signals correct parse error" $+        property $ \ch -> do+          let ms = ueof <> etok (toLower ch) <> etok (toUpper ch)+          prs  (char' ch) "" `shouldFailWith` err posI ms++  describe "anyChar" $ do+    context "when stream is not empty" $+      it "succeeds consuming next character in the stream" $+        property $ \ch s -> do+          let s' = ch : s+          prs  anyChar s' `shouldParse`     ch+          prs' anyChar s' `succeedsLeaving` s+    context "when stream is empty" $+      it "signals correct parse error" $+        prs anyChar "" `shouldFailWith` err posI (ueof <> elabel "character")++  describe "oneOf" $ do+    context "when stream begins with one of specified characters" $+      it "parses the character" $+        property $ \chs' n s -> do+          let chs = getNonEmpty chs'+              ch  = chs !! (getNonNegative n `rem` length chs)+              s'  = ch : s+          prs  (oneOf chs) s' `shouldParse`     ch+          prs' (oneOf chs) s' `succeedsLeaving` s+    context "when stream does not begin with any of specified characters" $+      it "signals correct parse error" $+        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do+          let s' = ch : s+          prs  (oneOf chs) s' `shouldFailWith` err posI (utok ch)+          prs' (oneOf chs) s' `failsLeaving`   s'+    context "when stream is empty" $+      it "signals correct parse error" $+        property $ \chs ->+          prs (oneOf (chs :: String)) "" `shouldFailWith` err posI ueof++  describe "oneOf'" $ do+    context "when stream begins with one of specified characters" $+      it "parses the character" $+        property $ \chs' n s -> do+          let chs = getNonEmpty chs'+              ch  = chs !! (getNonNegative n `rem` length chs)+              sl  = toLower ch : s+              su  = toUpper ch : s+          prs  (oneOf' chs) sl `shouldParse`     toLower ch+          prs  (oneOf' chs) su `shouldParse`     toUpper ch+          prs' (oneOf' chs) sl `succeedsLeaving` s+          prs' (oneOf' chs) su `succeedsLeaving` s+    context "when stream does not begin with any of specified characters" $+      it "signals correct parse error" $+        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do+          let s' = ch : s+          prs  (oneOf' chs) s' `shouldFailWith` err posI (utok ch)+          prs' (oneOf' chs) s' `failsLeaving`   s'+    context "when stream is empty" $+      it "signals correct parse error" $+        property $ \chs ->+          prs (oneOf' (chs :: String)) "" `shouldFailWith` err posI ueof++  describe "noneOf" $ do+    context "when stream does not begin with any of specified characters" $+      it "parses the character" $+        property $ \chs ch s  -> ch `notElem` (chs :: String) ==> do+          let s' = ch : s+          prs  (noneOf chs) s' `shouldParse`     ch+          prs' (noneOf chs) s' `succeedsLeaving` s+    context "when stream begins with one of specified characters" $+      it "signals correct parse error" $+        property $ \chs' n s -> do+          let chs = getNonEmpty chs'+              ch  = chs !! (getNonNegative n `rem` length chs)+              s'  = ch : s+          prs  (noneOf chs) s' `shouldFailWith` err posI (utok ch)+          prs' (noneOf chs) s' `failsLeaving`   s'+    context "when stream is empty" $+      it "signals correct parse error" $+        property $ \chs ->+          prs (noneOf (chs :: String)) "" `shouldFailWith` err posI ueof++  describe "noneOf'" $ do+    context "when stream does not begin with any of specified characters" $+      it "parses the character" $+        property $ \chs ch s  -> ch `notElemi` (chs :: String) ==> do+          let sl  = toLower ch : s+              su  = toUpper ch : s+          prs  (noneOf' chs) sl `shouldParse`     toLower ch+          prs  (noneOf' chs) su `shouldParse`     toUpper ch+          prs' (noneOf' chs) sl `succeedsLeaving` s+          prs' (noneOf' chs) su `succeedsLeaving` s+    context "when stream begins with one of specified characters" $+      it "signals correct parse error" $+        property $ \chs' n s -> do+          let chs = getNonEmpty chs'+              ch  = chs !! (getNonNegative n `rem` length chs)+              s'  = ch : s+          prs  (noneOf' chs) s' `shouldFailWith` err posI (utok ch)+          prs' (noneOf' chs) s' `failsLeaving`   s'+    context "when stream is empty" $+      it "signals correct parse error" $+        property $ \chs ->+          prs (noneOf' (chs :: String)) "" `shouldFailWith` err posI ueof++  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 n = length (takeWhile (uncurry (==)) (zip str s)) + 1+              common = take n s+          prs  (string str) s `shouldFailWith` err posI (utoks common <> 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+            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 n = length (takeWhile (uncurry casei) (zip str s)) + 1+              common = take n s+          prs  (string' str) s `shouldFailWith` err posI (utoks common <> etoks str)++----------------------------------------------------------------------------+-- Helpers++checkStrLit :: String -> String -> Parsec Dec String 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+       prs  p s' `shouldFailWith` err posI (utok ch <> etoks ts)+       prs' p s' `failsLeaving`   s'+  context "when stream is empty" $+    it "signals correct parse error" $+      prs p "" `shouldFailWith` err posI (ueof <> etoks ts)++checkCharPred :: String -> (Char -> Bool) -> Parsec Dec String 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 posI (utok ch <> elabel name)+       prs' p s' `failsLeaving`   s'+  context "when stream is empty" $+    it "signals correct parse error" $+      prs p "" `shouldFailWith` err posI (ueof <> elabel name)++checkCharRange :: String -> String -> Parsec Dec String Char -> SpecWith ()+checkCharRange name tchs p = do+  forM_ tchs $ \tch ->+    context ("when stream begins with " ++ showTokens (nes tch)) $+      it ("parses the " ++ showTokens (nes tch)) $+        property $ \s -> do+          let s' = tch : s+          prs  p s' `shouldParse`     tch+          prs' p s' `succeedsLeaving` s+  context ("when stream does not begin with " ++ name) $+    it "signals correct parse error" $+      property $ \ch s -> ch `notElem` tchs ==> do+       let s' = ch : s+       prs  p s' `shouldFailWith` err posI (utok ch <> elabel name)+       prs' p s' `failsLeaving`   s'+  context "when stream is empty" $+    it "signals correct parse error" $+      prs p "" `shouldFailWith` err posI (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++-- | Case-insensitive equality test for characters.++casei :: Char -> Char -> Bool+casei x y = toUpper x == toUpper y++-- | Case-insensitive 'elem'.++elemi :: Char -> String -> Bool+elemi c = any (casei c)++-- | Case-insensitive 'notElem'.++notElemi :: Char -> String -> Bool+notElemi c = not . elemi c++-- | 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

@@ -0,0 +1,256 @@+--+-- Tests for Megaparsec's generic parser combinators.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE MultiWayIf #-}++module Text.Megaparsec.CombinatorSpec (spec) where++import Control.Applicative+import Data.Char (isLetter, isDigit)+import Data.List (intersperse)+import Data.Maybe (fromMaybe, maybeToList, isNothing, fromJust)+import Data.Monoid+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Char+import Text.Megaparsec.Combinator++spec :: Spec+spec = do++  describe "between" . it "works" . property $ \pre c n' post -> do+    let p = between (string pre) (string post) (many (char c))+        n = getNonNegative n'+        b = length (takeWhile (== c) post)+        z = replicate n c+        s = pre ++ z ++ post+    if b > 0+      then prs_ p s `shouldFailWith` err (posN (length pre + n + b) s)+        ( etoks post <> etok c <>+          (if length post == b then ueof else utoks [post !! b]) )+      else prs_ p s `shouldParse` z++  describe "choice" . it "works" . property $ \cs' s' -> do+    let cs = getNonEmpty cs'+        p = choice (char <$> cs)+        s = [s']+    if s' `elem` cs+      then prs_ p s `shouldParse` s'+      else prs_ p s `shouldFailWith` err posI (utok s' <> mconcat (etok <$> cs))++  describe "count" . it "works" . property $ \n x' -> do+    let x = getNonNegative x'+        p = count n (char 'x')+        p' = count' n n (char 'x')+        s = replicate x 'x'+    prs_ p s `shouldBe` prs_ p' s++  describe "count'" . it "works" . property $ \m n x' -> do+    let x = getNonNegative x'+        p = count' m n (char 'x')+        s = replicate x 'x'+    if | n <= 0 || m > n ->+         if x == 0+           then prs_ p s `shouldParse` ""+           else prs_ p s `shouldFailWith` err posI (utok 'x' <> eeof)+       | m <= x && x <= n ->+         prs_ p s `shouldParse` s+       | x < m ->+         prs_ p s `shouldFailWith` err (posN x s) (ueof <> etok 'x')+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN n s) (utok 'x' <> eeof)++  describe "eitherP" . it "works" . property $ \ch -> do+    let p = eitherP letterChar digitChar+        s = pure ch+    if | isLetter ch -> prs_ p s `shouldParse` Left ch+       | isDigit  ch -> prs_ p s `shouldParse` Right ch+       | otherwise   -> prs_ p s `shouldFailWith`+         err posI (utok ch <> elabel "letter" <> elabel "digit")++  describe "endBy" . it "works" . property $ \n' c -> do+    let n = getNonNegative n'+        p = endBy (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ [c]+    if | c == 'a' && n == 0 ->+         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+       | c == 'a' ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+       | c == '-' && n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a'<> eeof)+       | c /= '-' ->+         prs_ p s `shouldFailWith` err (posN (g n) s)+           ( utok c <>+             (if n > 0 then etok '-' else eeof) <>+             (if n == 0 then etok 'a' else mempty) )+       | otherwise -> prs_ p s `shouldParse` replicate n 'a'++  describe "endBy1" . it "works" . property $ \n' c -> do+    let n = getNonNegative n'+        p = endBy1 (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ [c]+    if | c == 'a' && n == 0 ->+         prs_ p s `shouldFailWith` err (posN (1 :: Int) s) (ueof <> etok '-')+       | c == 'a' ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok 'a' <> etok '-')+       | c == '-' && n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok '-' <> etok 'a')+       | c /= '-' ->+         prs_ p s `shouldFailWith` err (posN (g n) s)+           ( utok c <>+             (if n > 0 then etok '-' else mempty) <>+             (if n == 0 then etok 'a' else mempty) )+       | otherwise -> prs_ p s `shouldParse` replicate n 'a'++  describe "manyTill" . it "works" . property $ \a' b' c' -> do+    let [a,b,c] = getNonNegative <$> [a',b',c']+        p = (,) <$> manyTill letterChar (char 'c') <*> many letterChar+        s = abcRow a b c+    if c == 0+      then prs_ p s `shouldFailWith` err (posN (a + b) s)+           (ueof <> etok 'c' <> elabel "letter")+      else let (pre, post) = break (== 'c') s+           in prs_ p s `shouldParse` (pre, drop 1 post)++  describe "someTill" . it "works" . property $ \a' b' c' -> do+    let [a,b,c] = getNonNegative <$> [a',b',c']+        p = (,) <$> someTill letterChar (char 'c') <*> many letterChar+        s = abcRow a b c+    if | null s ->+         prs_ p s `shouldFailWith` err posI (ueof <> elabel "letter")+       | c == 0 ->+         prs_ p s `shouldFailWith` err (posN (a + b) s)+           (ueof <> etok 'c' <> elabel "letter")+       | s == "c" ->+         prs_ p s `shouldFailWith` err+           (posN (1 :: Int) s) (ueof <> etok 'c' <> elabel "letter")+       | head s == 'c' ->+         prs_ p s `shouldParse` ("c", drop 2 s)+       | otherwise ->+         let (pre, post) = break (== 'c') s+         in prs_ p s `shouldParse` (pre, drop 1 post)++  describe "option" . it "works" . property $ \d a s -> do+    let p = option d (string a)+        p' = fromMaybe d <$> optional (string a)+    prs_ p s `shouldBe` prs_ p' s++  describe "sepBy" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepBy (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' ->+         prs_ p s `shouldParse` replicate n 'a'+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI+           (utok c <> etok 'a' <> eeof)+       | c == '-' ->+         prs_ p s `shouldFailWith` err (posN (length s) s)+           (ueof <> etok 'a')+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s)+           (utok c <> etok '-' <> eeof)++  describe "sepBy1" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepBy1 (char 'a') (char '-')+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' && n >= 1 ->+         prs_ p s `shouldParse` replicate n 'a'+       | isNothing c' ->+         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+       | c == '-' ->+         prs_ p s `shouldFailWith` err (posN (length s) s) (ueof <> etok 'a')+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)++  describe "sepEndBy" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepEndBy (char 'a') (char '-')+        a = replicate n 'a'+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' ->+         prs_ p s `shouldParse` a+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a' <> eeof)+       | c == '-' ->+         prs_ p s `shouldParse` a+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)++  describe "sepEndBy1" . it "works" . property $ \n' c' -> do+    let n = getNonNegative n'+        c = fromJust c'+        p = sepEndBy1 (char 'a') (char '-')+        a = replicate n 'a'+        s = intersperse '-' (replicate n 'a') ++ maybeToList c'+    if | isNothing c' && n >= 1 ->+         prs_ p s `shouldParse` a+       | isNothing c' ->+         prs_ p s `shouldFailWith` err posI (ueof <> etok 'a')+       | c == 'a' && n == 0 ->+         prs_ p s `shouldParse` "a"+       | n == 0 ->+         prs_ p s `shouldFailWith` err posI (utok c <> etok 'a')+       | c == '-' ->+         prs_ p s `shouldParse` a+       | otherwise ->+         prs_ p s `shouldFailWith` err (posN (g n) s) (utok c <> etok '-' <> eeof)++  describe "skipMany" . it "works" . property $ \c n' a -> do+    let p = skipMany (char c) *> string a+        n = getNonNegative n'+        p' = many (char c) >> string a+        s = replicate n c ++ a+    prs_ p s `shouldBe` prs_ p' s++  describe "skipSome" . it "works" . property $ \c n' a -> do+    let p = skipSome (char c) *> string a+        n = getNonNegative n'+        p' = some (char c) >> string a+        s = replicate n c ++ a+    prs_ p s `shouldBe` prs_ p' s++----------------------------------------------------------------------------+-- Helpers++g :: Int -> Int+g x = x + if x > 0 then x - 1 else 0

@@ -0,0 +1,223 @@+--+-- Tests for Megaparsec's parse errors.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP              #-}+{-# OPTIONS -fno-warn-orphans #-}++module Text.Megaparsec.ErrorSpec (spec) where++import Data.Char (isControl, isSpace)+import Data.Function (on)+import Data.List (isInfixOf, isSuffixOf)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid+import Data.Set (Set)+import Test.Hspec+import Test.QuickCheck+import Text.Megaparsec.Error+import Text.Megaparsec.Pos+import qualified Data.List.NonEmpty as NE+import qualified Data.Semigroup     as S+import qualified Data.Set           as E++#if !MIN_VERSION_base(4,8,0)+import Data.Foldable (Foldable, all)+import Prelude hiding (all)+#else+import Control.Exception (Exception (..))+#endif++type PE = ParseError Char Dec++spec :: Spec+spec = do++  describe "Semigroup instance of ParseError" $+    it "associativity" $+      property $ \x y z ->+        (x S.<> y) S.<> z === (x S.<> (y S.<> z) :: PE)++  describe "Monoid instance of ParseError" $ do+    it "left identity" $+      property $ \x ->+        mempty <> x === (x :: PE)+    it "right identity" $+      property $ \x ->+        x <> mempty === (x :: PE)+    it "associativity" $+      property $ \x y z ->+        (x <> y) <> z === (x <> (y <> z) :: PE)++  describe "Read and Show instances of ParseError" $+    it "printed representation of ParseError can be read back" $+      property $ \x ->+        read (show x) === (x :: PE)++  describe "error merging with (<>)" $ do+    it "selects greater source position" $+      property $ \x y ->+        errorPos (x <> y :: PE) === max (errorPos x) (errorPos y)+    it "merges unexpected items correctly" $+      property (checkMergedItems errorUnexpected)+    it "merges expected items correctly" $+      property (checkMergedItems errorExpected)+    it "merges custom items correctly" $+      property (checkMergedItems errorCustom)++  describe "showTokens (Char instance)" $ do+    let f x y = showTokens (NE.fromList x) `shouldBe` y+    it "shows CRLF newline correctly"+      (f "\r\n" "crlf newline")+    it "shows null byte correctly"+      (f "\NUL" "null (control character)")+    it "shows start of heading correctly"+      (f "\SOH" "start of heading (control character)")+    it "shows start of text correctly"+      (f "\STX" "start of text (control character)")+    it "shows end of text correctly"+      (f "\ETX" "end of text (control character)")+    it "shows end of transmission correctly"+      (f "\EOT" "end of transmission (control character)")+    it "shows enquiry correctly"+      (f "\ENQ" "enquiry (control character)")+    it "shows acknowledge correctly"+      (f "\ACK" "acknowledge (control character)")+    it "shows bell correctly"+      (f "\BEL" "bell (control character)")+    it "shows backspace correctly"+      (f "\BS" "backspace")+    it "shows tab correctly"+      (f "\t" "tab")+    it "shows newline correctly"+      (f "\n" "newline")+    it "shows vertical tab correctly"+      (f "\v" "vertical tab")+    it "shows form feed correctly"+      (f "\f" "form feed (control character)")+    it "shows carriage return correctly"+      (f "\r" "carriage return")+    it "shows shift out correctly"+      (f "\SO" "shift out (control character)")+    it "shows shift in correctly"+      (f "\SI" "shift in (control character)")+    it "shows data link escape correctly"+      (f "\DLE" "data link escape (control character)")+    it "shows device control one correctly"+      (f "\DC1" "device control one (control character)")+    it "shows device control two correctly"+      (f "\DC2" "device control two (control character)")+    it "shows device control three correctly"+      (f "\DC3" "device control three (control character)")+    it "shows device control four correctly"+      (f "\DC4" "device control four (control character)")+    it "shows negative acknowledge correctly"+      (f "\NAK" "negative acknowledge (control character)")+    it "shows synchronous idle correctly"+      (f "\SYN" "synchronous idle (control character)")+    it "shows end of transmission block correctly"+      (f "\ETB" "end of transmission block (control character)")+    it "shows cancel correctly"+      (f "\CAN" "cancel (control character)")+    it "shows end of medium correctly"+      (f "\EM"  "end of medium (control character)")+    it "shows substitute correctly"+      (f "\SUB" "substitute (control character)")+    it "shows escape correctly"+      (f "\ESC" "escape (control character)")+    it "shows file separator correctly"+      (f "\FS"  "file separator (control character)")+    it "shows group separator correctly"+      (f "\GS"  "group separator (control character)")+    it "shows record separator correctly"+      (f "\RS"  "record separator (control character)")+    it "shows unit separator correctly"+      (f "\US"  "unit separator (control character)")+    it "shows delete correctly"+      (f "\DEL" "delete (control character)")+    it "shows space correctly"+      (f " "    "space")+    it "shows non-breaking space correctly"+      (f "\160" "non-breaking space")+    it "shows other single characters in single quotes" $+      property $ \ch ->+        not (isControl ch) && not (isSpace ch) ==>+          showTokens (ch :| []) === ['\'',ch,'\'']+    it "shows strings in double quotes" $+      property $ \str ->+        (length str > 1) && (str /= "\r\n") ==>+          showTokens (NE.fromList str) === ("\"" ++ str ++"\"")++  describe "parseErrorPretty" $ do+    it "shows unknown ParseError correctly" $+      parseErrorPretty (mempty :: PE) `shouldBe` "1:1:\nunknown parse error\n"+    it "result always ends with a newline" $+      property $ \x ->+        parseErrorPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)+    it "result contains representation of source pos stack" $+      property (contains errorPos sourcePosPretty)+    it "result contains representation of unexpected items" $+      property (contains errorUnexpected showErrorComponent)+    it "result contains representation of expected items" $+      property (contains errorExpected showErrorComponent)+    it "result contains representation of custom items" $+      property (contains errorCustom showErrorComponent)++  describe "sourcePosStackPretty" $+    it "result never ends with a newline " $+      property $ \x ->+        let pos = errorPos (x :: PE)+        in sourcePosStackPretty pos `shouldNotSatisfy` ("\n" `isSuffixOf`)++  describe "parseErrorTextPretty" $ do+    it "shows unknown ParseError correctly" $+      parseErrorTextPretty (mempty :: PE) `shouldBe` "unknown parse error\n"+    it "result always ends with a newline" $+      property $ \x ->+        parseErrorTextPretty (x :: PE) `shouldSatisfy` ("\n" `isSuffixOf`)++#if MIN_VERSION_base(4,8,0)+  describe "displayException" $+    it "produces the same result as parseErrorPretty" $+      property $ \x ->+        displayException x `shouldBe` parseErrorPretty (x :: PE)+#endif++----------------------------------------------------------------------------+-- Helpers++checkMergedItems :: (Ord a, Show a) => (PE -> Set a) -> PE -> PE -> Property+checkMergedItems f e1 e2 = f (e1 <> e2) === r+  where r = case (compare `on` errorPos) e1 e2 of+              LT -> f e2+              EQ -> (E.union `on` f) e1 e2+              GT -> f e1++contains :: Foldable t => (PE -> t a) -> (a -> String) -> PE -> Property+contains g r e = property (all f (g e))+  where rendered = parseErrorPretty e+        f x = r x `isInfixOf` rendered

@@ -0,0 +1,187 @@+--+-- Tests for Megaparsec's expression parsers.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}++module Text.Megaparsec.ExprSpec (spec) where++import Control.Applicative (some, (<|>))+import Data.Monoid ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Char+import Text.Megaparsec.Combinator+import Text.Megaparsec.Expr+import Text.Megaparsec.Prim++#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>), (<*), (<*>), (*>), pure)+#endif++spec :: Spec+spec =+  describe "makeExprParser" $ do+    context "when given valid rendered AST" $+      it "can parse it back" $+        property $ \node -> do+          let s = showNode node+          prs  expr s `shouldParse`     node+          prs' expr s `succeedsLeaving` ""+    context "when stream in empty" $+      it "signals correct parse error" $+        prs (expr <* eof) "" `shouldFailWith` err posI (ueof <> elabel "term")+    context "when term is missing" $+      it "signals correct parse error" $ do+        let p = expr <* eof+            n = 1 :: Integer+        prs p "-" `shouldFailWith` err (posN n "-") (ueof <> elabel "term")+        prs p "(" `shouldFailWith` err (posN n "(") (ueof <> elabel "term")+        prs p "*" `shouldFailWith` err posI (utok '*' <> elabel "term")+    context "operator is missing" $+      it "signals correct parse error" $+        property $ \a b -> do+          let p = expr <* eof+              a' = inParens a+              n  = length a' + 1+              s  = a'  ++ " " ++ inParens b+              c  = s !! n+          if c == '-'+            then prs p s `shouldParse` Sub a b+            else prs p s `shouldFailWith`+                 err (posN n s) (utok c <> eeof <> elabel "operator")++-- Algebraic structures to build abstract syntax tree of our expression.++data Node+  = Val Integer   -- ^ literal value+  | Neg Node      -- ^ negation (prefix unary)+  | Fac Node      -- ^ factorial (postfix unary)+  | Mod Node Node -- ^ modulo+  | Sum Node Node -- ^ summation (addition)+  | Sub Node Node -- ^ subtraction+  | Pro Node Node -- ^ product+  | Div Node Node -- ^ division+  | Exp Node Node -- ^ exponentiation+    deriving (Eq, Show)++instance Enum Node where+  fromEnum (Val _)   = 0+  fromEnum (Neg _)   = 0+  fromEnum (Fac _)   = 0+  fromEnum (Mod _ _) = 0+  fromEnum (Exp _ _) = 1+  fromEnum (Pro _ _) = 2+  fromEnum (Div _ _) = 2+  fromEnum (Sum _ _) = 3+  fromEnum (Sub _ _) = 3+  toEnum   _         = error "Oops!"++instance Ord Node where+  x `compare` y = fromEnum x `compare` fromEnum y++showNode :: Node -> String+showNode (Val x)     = show x+showNode n@(Neg x)   = "-" ++ showGT n x+showNode n@(Fac x)   = showGT n x ++ "!"+showNode n@(Mod x y) = showGE n x ++ " % " ++ showGE n y+showNode n@(Sum x y) = showGT n x ++ " + " ++ showGE n y+showNode n@(Sub x y) = showGT n x ++ " - " ++ showGE n y+showNode n@(Pro x y) = showGT n x ++ " * " ++ showGE n y+showNode n@(Div x y) = showGT n x ++ " / " ++ showGE n y+showNode n@(Exp x y) = showGE n x ++ " ^ " ++ showGT n y++showGT :: Node -> Node -> String+showGT parent node = (if node > parent then showCmp else showNode) node++showGE :: Node -> Node -> String+showGE parent node = (if node >= parent then showCmp else showNode) node++showCmp :: Node -> String+showCmp node = (if fromEnum node == 0 then showNode else inParens) node++inParens :: Node -> String+inParens x = "(" ++ showNode x ++ ")"++instance Arbitrary Node where+  arbitrary = sized arbitraryN0++arbitraryN0 :: Int -> Gen Node+arbitraryN0 n = frequency [ (1, Mod <$> leaf <*> leaf)+                          , (9, arbitraryN1 n) ]+  where leaf = arbitraryN1 (n `div` 2)++arbitraryN1 :: Int -> Gen Node+arbitraryN1 n =+ frequency [ (1, Neg <$> arbitraryN2 n)+           , (1, Fac <$> arbitraryN2 n)+           , (7, arbitraryN2 n)]++arbitraryN2 :: Int -> Gen Node+arbitraryN2 0 = Val . getNonNegative <$> arbitrary+arbitraryN2 n = elements [Sum,Sub,Pro,Div,Exp] <*> leaf <*> leaf+  where leaf = arbitraryN0 (n `div` 2)++-- Some helpers are put here since we don't want to depend on+-- "Text.Megaparsec.Lexer".++lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a+lexeme p = p <* hidden space++symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String+symbol = lexeme . string++parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a+parens = between (symbol "(") (symbol ")")++integer :: (MonadParsec e s m, Token s ~ Char) => m Integer+integer = lexeme (read <$> some digitChar <?> "integer")++-- Here we use a table of operators that makes use of all features of+-- 'makeExprParser'. Then we generate abstract syntax tree (AST) of complex+-- but valid expressions and render them to get their textual+-- representation.++expr :: (MonadParsec e s m, Token s ~ Char) => m Node+expr = makeExprParser term table++term :: (MonadParsec e s m, Token s ~ Char) => m Node+term = parens expr <|> (Val <$> integer) <?> "term"++table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]]+table = [ [ Prefix  (symbol "-" *> pure Neg)+          , Postfix (symbol "!" *> pure Fac)+          , InfixN  (symbol "%" *> pure Mod) ]+        , [ InfixR  (symbol "^" *> pure Exp) ]+        , [ InfixL  (symbol "*" *> pure Pro)+          , InfixL  (symbol "/" *> pure Div) ]+        , [ InfixL  (symbol "+" *> pure Sum)+          , InfixL  (symbol "-" *> pure Sub)] ]

@@ -0,0 +1,486 @@+--+-- Tests for Megaparsec's lexer.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiWayIf       #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE TypeFamilies     #-}++module Text.Megaparsec.LexerSpec (spec) where++import Control.Applicative+import Control.Monad (void)+import Data.Char hiding (ord)+import Data.List (isInfixOf)+import Data.Maybe+import Data.Monoid ((<>))+import Data.Scientific (fromFloatDigits)+import Numeric (showInt, showHex, showOct)+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Error+import Text.Megaparsec.Lexer+import Text.Megaparsec.Pos+import Text.Megaparsec.Prim+import Text.Megaparsec.String+import qualified Text.Megaparsec.Char as C++spec :: Spec+spec = do++  describe "space" $+    it "consumes any sort of white space" $+      property $ forAll mkWhiteSpace $ \s -> do+        prs  scn s `shouldParse` ()+        prs' scn s `succeedsLeaving` ""++  describe "symbol" $+    context "when stream begins with the symbol" $+      it "parses the symbol and trailing whitespace" $+        property $ forAll mkSymbol $ \s -> do+          let p = symbol scn y+              y = takeWhile (not . isSpace) s+          prs  p s `shouldParse` y+          prs' p s `succeedsLeaving` ""++  describe "symbol'" $+    context "when stream begins with the symbol" $+      it "parses the symbol and trailing whitespace" $+        property $ forAll mkSymbol $ \s -> do+          let p = symbol' scn (toUpper <$> y)+              y = takeWhile (not . isSpace) s+          prs  p s `shouldParse` y+          prs' p s `succeedsLeaving` ""++  describe "skipLineComment" $+    context "when there is no newline at the end of line" $+      it "is picked up successfully" $ do+        let p = space (void C.spaceChar) (skipLineComment "//") empty <* eof+            s = "  // this line comment doesn't have a newline at the end "+        prs  p s `shouldParse` ()+        prs' p s `succeedsLeaving` ""++  describe "skipBlockCommentNested" $+    context "when it runs into nested block comments" $+      it "parses them all right" $ do+        let p = space (void C.spaceChar) empty+              (skipBlockCommentNested "/*" "*/") <* eof+            s = " /* foo bar /* baz */ quux */ "+        prs  p s `shouldParse` ()+        prs' p s `succeedsLeaving` ""++  describe "indentLevel" $+    it "returns current indentation level (column)" $+      property $ \pos -> do+        let p = setPosition pos *> indentLevel+        prs p "" `shouldParse` sourceColumn pos++  describe "incorrectIndent" $+    it "signals correct parse error" $+      property $ \ord ref actual -> do+        let p :: Parser ()+            p = incorrectIndent ord ref actual+        prs p "" `shouldFailWith` err posI (ii ord ref actual)++  describe "indentGuard" $+    it "works as intended" $+      property $ \n -> do+        let mki = mkIndent sbla (getSmall $ getNonNegative n)+        forAll ((,,) <$> mki <*> mki <*> mki) $ \(l0,l1,l2) -> do+          let (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)+              fragments = [l0,l1,l2]+              g x = sum (length <$> take x fragments)+              s = concat fragments+              p  = ip GT pos1 >>=+                \x -> sp >> ip EQ x >> sp >> ip GT x >> sp >> scn+              ip = indentGuard scn+              sp = void (symbol sc sbla <* C.eol)+          if | col0 <= pos1 ->+               prs p s `shouldFailWith` err posI (ii GT pos1 col0)+             | col1 /= col0 ->+               prs p s `shouldFailWith` err (posN (getIndent l1 + g 1) s) (ii EQ col0 col1)+             | col2 <= col0 ->+               prs p s `shouldFailWith` err (posN (getIndent l2 + g 2) s) (ii GT col0 col2)+             | otherwise    ->+               prs p s `shouldParse` ()++  describe "nonIdented" $+    it "works as intended" $+      property $ forAll (mkIndent sbla 0) $ \s -> do+        let p = nonIndented scn (symbol scn sbla)+            i = getIndent s+        if i == 0+          then prs p s `shouldParse` sbla+          else prs p s `shouldFailWith` err (posN i s) (ii EQ pos1 (getCol s))++  describe "indentBlock" $ do+    it "works as indented" $+      property $ \mn'' -> do+        let mkBlock = do+              l0 <- mkIndent sbla 0+              l1 <- mkIndent sblb ib+              l2 <- mkIndent sblc (ib + 2)+              l3 <- mkIndent sblb ib+              l4 <- mkIndent' sblc (ib + 2)+              return (l0,l1,l2,l3,l4)+            ib  = fromMaybe 2 mn'+            mn' = getSmall . getPositive <$> mn''+            mn  = unsafePos . fromIntegral <$> mn'+        forAll mkBlock $ \(l0,l1,l2,l3,l4) -> do+          let (col0, col1, col2, col3, col4) =+                (getCol l0, getCol l1, getCol l2, getCol l3, getCol l4)+              fragments = [l0,l1,l2,l3,l4]+              g x = sum (length <$> take x fragments)+              s = concat fragments+              p = lvla <* eof+              lvla = indentBlock scn $ IndentMany mn      (l sbla) lvlb <$ b sbla+              lvlb = indentBlock scn $ IndentSome Nothing (l sblb) lvlc <$ b sblb+              lvlc = indentBlock scn $ IndentNone                  sblc <$ b sblc+              b    = symbol sc+              l x  = return . (x,)+              ib'  = unsafePos (fromIntegral ib)+          if | col1 <= col0 -> prs p s `shouldFailWith`+               err (posN (getIndent l1 + g 1) s) (utok (head sblb) <> eeof)+             | isJust mn && col1 /= ib' -> prs p s `shouldFailWith`+               err (posN (getIndent l1 + g 1) s) (ii EQ ib' col1)+             | col2 <= col1 -> prs p s `shouldFailWith`+               err (posN (getIndent l2 + g 2) s) (ii GT col1 col2)+             | col3 == col2 -> prs p s `shouldFailWith`+               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> etoks sblc)+             | col3 <= col0 -> prs p s `shouldFailWith`+               err (posN (getIndent l3 + g 3) s) (utok (head sblb) <> eeof)+             | col3 < col1 -> prs p s `shouldFailWith`+               err (posN (getIndent l3 + g 3) s) (ii EQ col1 col3)+             | col3 > col1 -> prs p s `shouldFailWith`+               err (posN (getIndent l3 + g 3) s) (ii EQ col2 col3)+             | col4 <= col3 -> prs p s `shouldFailWith`+               err (posN (getIndent l4 + g 4) s) (ii GT col3 col4)+             | otherwise -> prs p s `shouldParse`+               (sbla, [(sblb, [sblc]), (sblb, [sblc])])+    it "IndentMany works as intended" $+      property $ forAll (mkIndent sbla 0) $ \s -> do+        let p    = lvla+            lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla+            lvlb = b sblb+            b    = symbol sc+            l x  = return . (x,)+        prs  p s `shouldParse` (sbla, [])+        prs' p s `succeedsLeaving` ""++  describe "lineFold" $+    it "works as intended" $+      property $ do+        let mkFold = do+              l0 <- mkInterspace sbla 0+              l1 <- mkInterspace sblb 1+              l2 <- mkInterspace sblc 1+              return (l0,l1,l2)+        forAll mkFold $ \(l0,l1,l2) -> do+          let p = lineFold scn $ \sc' -> do+                a <- symbol sc' sbla+                b <- symbol sc' sblb+                c <- symbol scn sblc+                return (a, b, c)+              getEnd x = last x == '\n'+              fragments = [l0,l1,l2]+              g x = sum (length <$> take x fragments)+              s = concat fragments+              (col0, col1, col2) = (getCol l0, getCol l1, getCol l2)+              (end0, end1)       = (getEnd l0, getEnd l1)+          if | end0 && col1 <= col0 -> prs p s `shouldFailWith`+               err (posN (getIndent l1 + g 1) s) (ii GT col0 col1)+             | end1 && col2 <= col0 -> prs p s `shouldFailWith`+               err (posN (getIndent l2 + g 2) s) (ii GT col0 col2)+             | otherwise -> prs p s `shouldParse` (sbla, sblb, sblc)++  describe "charLiteral" $ do+    context "when stream begins with a literal character" $+      it "parses it" $+        property $ \ch -> do+          let p = charLiteral+              s = showLitChar ch ""+          prs  p s `shouldParse` ch+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with a literal character" $+      it "signals correct parse error" $ do+        let p = charLiteral+            s = "\\"+        prs  p s `shouldFailWith` err posI (utok '\\' <> elabel "literal character")+        prs' p s `failsLeaving` s+    context "when stream is empty" $+      it "signals correct parse error" $ do+        let p = charLiteral+        prs p "" `shouldFailWith` err posI (ueof <> elabel "literal character")++  describe "integer" $ do+    context "when stream begins with decimal digits" $+      it "they are parsed as an integer" $+        property $ \n' -> do+          let p = integer+              n = getNonNegative n'+              s = showInt n ""+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with decimal digits" $+      it "signals correct parse error" $+        property $ \a as -> not (isDigit a) ==> do+          let p = integer+              s = a : as+          prs  p s `shouldFailWith` err posI (utok a <> elabel "integer")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs integer "" `shouldFailWith`+          err posI (ueof <> elabel "integer")++  describe "decimal" $ do+    context "when stream begins with decimal digits" $+      it "they are parsed as an integer" $+        property $ \n' -> do+          let p = decimal+              n = getNonNegative n'+              s = showInt n ""+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with decimal digits" $+      it "signals correct parse error" $+        property $ \a as -> not (isDigit a) ==> do+          let p = decimal+              s = a : as+          prs  p s `shouldFailWith` err posI (utok a <> elabel "decimal integer")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs decimal "" `shouldFailWith`+          err posI (ueof <> elabel "decimal integer")++  describe "hexadecimal" $ do+    context "when stream begins with hexadecimal digits" $+      it "they are parsed as an integer" $+        property $ \n' -> do+          let p = hexadecimal+              n = getNonNegative n'+              s = showHex n ""+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with hexadecimal digits" $+      it "signals correct parse error" $+        property $ \a as -> not (isHexDigit a) ==> do+          let p = hexadecimal+              s = a : as+          prs  p s `shouldFailWith`+            err posI (utok a <> elabel "hexadecimal integer")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs hexadecimal "" `shouldFailWith`+          err posI (ueof <> elabel "hexadecimal integer")++  describe "octal" $ do+    context "when stream begins with octal digits" $+      it "they are parsed as an integer" $+        property $ \n' -> do+          let p = octal+              n = getNonNegative n'+              s = showOct n ""+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with octal digits" $+      it "signals correct parse error" $+        property $ \a as -> not (isOctDigit a) ==> do+          let p = octal+              s = a : as+          prs  p s `shouldFailWith`+            err posI (utok a <> elabel "octal integer")+    context "when stream is empty" $+      it "signals correct parse error" $+        prs octal "" `shouldFailWith`+          err posI (ueof <> elabel "octal integer")++  describe "float" $ do+    context "when stream begins with a float" $+      it "parses it" $+        property $ \n' -> do+          let p = float+              n = getNonNegative n'+              s = show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when stream does not begin with a float" $+      it "signals correct parse error" $+        property $ \a as -> not (isDigit a) ==> do+          let p = float+              s = a : as+          prs  p s `shouldFailWith`+            err posI (utok a <> elabel "floating point number")+          prs' p s `failsLeaving` s+    context "when stream begins with a decimal number" $+      it "signals correct parse error" $+        property $ \n' -> do+          let p = float+              n = getNonNegative n'+              s = show (n :: Integer)+          prs  p s `shouldFailWith` err (posN (length s) s)+            (ueof <> etok '.' <> etok 'E' <> etok 'e' <> elabel "digit")+          prs' p s `failsLeaving` ""+    context "when stream is empty" $+      it "signals correct parse error" $+        prs float "" `shouldFailWith`+          err posI (ueof <> elabel "floating point number")+    context "when there is float with exponent without explicit sign" $+      it "parses it all right" $ do+        let p = float+            s = "123e3"+        prs  p s `shouldParse` 123e3+        prs' p s `succeedsLeaving` ""++  describe "number" $ do+    context "when stream begins with a number" $+      it "parses it" $+        property $ \n' -> do+          let p = number+              s = either (show . getNonNegative) (show . getNonNegative)+                (n' :: Either (NonNegative Integer) (NonNegative Double))+          prs p s `shouldParse` case n' of+            Left  x -> fromIntegral    (getNonNegative x)+            Right x -> fromFloatDigits (getNonNegative x)+          prs' p s `succeedsLeaving` ""+    context "when stream is empty" $+      it "signals correct parse error" $+        prs number "" `shouldFailWith`+          err posI (ueof <> elabel "number")++  describe "signed" $ do+    context "with integer" $+      it "parses signed integers" $+        property $ \n -> do+          let p = signed (hidden C.space) integer+              s = show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "with float" $+      it "parses signed floats" $+        property $ \n -> do+          let p = signed (hidden C.space) float+              s = show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "with number" $+      it "parses singed numbers" $+        property $ \n -> do+          let p = signed (hidden C.space) number+              s = either show show (n :: Either Integer Double)+          prs p s `shouldParse` case n of+            Left  x -> fromIntegral    x+            Right x -> fromFloatDigits x+    context "when number is prefixed with plus sign" $+      it "parses the number" $+        property $ \n' -> do+          let p = signed (hidden C.space) integer+              n = getNonNegative n'+              s = '+' : show n+          prs  p s `shouldParse` n+          prs' p s `succeedsLeaving` ""+    context "when number is prefixed with white space" $+      it "signals correct parse error" $+        property $ \n -> do+          let p = signed (hidden C.space) integer+              s = ' ' : show (n :: Integer)+          prs  p s `shouldFailWith` err posI+            (utok ' ' <> etok '+' <> etok '-' <> elabel "integer")+          prs' p s `failsLeaving` s+    context "when there is white space between sign and digits" $+      it "parses it all right" $ do+        let p = signed (hidden C.space) integer+            s = "- 123"+        prs  p s `shouldParse` (-123)+        prs' p s `succeedsLeaving` ""++----------------------------------------------------------------------------+-- Helpers++mkWhiteSpace :: Gen String+mkWhiteSpace = concat <$> listOf whiteUnit+  where whiteUnit = oneof [whiteChars, whiteLine, whiteBlock]++mkSymbol :: Gen String+mkSymbol = (++) <$> symbolName <*> whiteChars++mkInterspace :: String -> Int -> Gen String+mkInterspace x n = oneof [si, mkIndent x n]+  where si = (++ x) <$> listOf (elements " \t")++mkIndent :: String -> Int -> Gen String+mkIndent x n = (++) <$> mkIndent' x n <*> eol+  where eol = frequency [(5, return "\n"), (1, listOf1 (return '\n'))]++mkIndent' :: String -> Int -> Gen String+mkIndent' x n = concat <$> sequence [spc, sym, tra]+  where spc = frequency [(5, vectorOf n itm), (1, listOf itm)]+        tra = listOf itm+        itm = elements " \t"+        sym = return x++whiteChars :: Gen String+whiteChars = listOf (elements "\t\n ")++whiteLine :: Gen String+whiteLine = commentOut <$> arbitrary `suchThat` goodEnough+  where commentOut x = "//" ++ x ++ "\n"+        goodEnough x = '\n' `notElem` x++whiteBlock :: Gen String+whiteBlock = commentOut <$> arbitrary `suchThat` goodEnough+  where commentOut x = "/*" ++ x ++ "*/"+        goodEnough x = not $ "*/" `isInfixOf` x++symbolName :: Gen String+symbolName = listOf $ arbitrary `suchThat` isAlphaNum++sc :: Parser ()+sc = space (void $ C.oneOf " \t") empty empty++scn :: Parser ()+scn = space (void C.spaceChar) l b+  where l = skipLineComment "//"+        b = skipBlockComment "/*" "*/"++getIndent :: String -> Int+getIndent = length . takeWhile isSpace++getCol :: String -> Pos+getCol x = sourceColumn .+  updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x++sbla, sblb, sblc :: String+sbla = "aaa"+sblb = "bbb"+sblc = "ccc"++ii :: Ordering -> Pos -> Pos -> EC Char Dec+ii ord ref actual = cstm (DecIndentation ord ref actual)

@@ -0,0 +1,125 @@+--+-- Tests for Megaparsec's permutation phrases parsers.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE MultiWayIf #-}++module Text.Megaparsec.PermSpec (spec) where++import Control.Applicative+import Data.List (nub, elemIndices)+import Data.Monoid+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Char+import Text.Megaparsec.Lexer (integer)+import Text.Megaparsec.Perm++data CharRows = CharRows+  { getChars :: (Char, Char, Char)+  , getInput :: String }+  deriving (Eq, Show)++instance Arbitrary CharRows where+  arbitrary = do+    chars@(a,b,c) <- arbitrary `suchThat` different+    an            <- arbitrary+    bn            <- arbitrary+    cn            <- arbitrary+    input <- concat <$> shuffle+             [ replicate an a+             , replicate bn b+             , replicate cn c]+    return $ CharRows chars input+      where different (a,b,c) = let l = [a,b,c] in l == nub l++spec :: Spec+spec = do++  describe "(<$$>)" $ do+    context "when supplied parser succeeds" $+      it "returns value returned by the parser" $+        property $ \n -> do+          let p = makePermParser (succ <$$> pure (n :: Integer))+          prs p "" `shouldParse` succ n+    context "when supplied parser fails" $+      it "signals correct parse error" $ do+          let p = makePermParser (succ <$$> integer)+          prs p "" `shouldFailWith` err posI (ueof <> elabel "integer")++  describe "(<$?>)" $ do+    context "when supplied parser succeeds" $+      it "returns value returned by the parser" $+        property $ \n m -> do+          let p = makePermParser (succ <$?> (n :: Integer, pure (m :: Integer)))+          prs p "" `shouldParse` succ m+    context "when supplied parser fails" $+      it "returns the default value" $+        property $ \n -> do+          let p = makePermParser (succ <$?> (n :: Integer, fail "foo"))+          prs p "" `shouldParse` succ n+    context "when stream in empty" $+      it "returns the default value" $+        property $ \n -> do+          let p = makePermParser (succ <$?> (n :: Integer, integer))+          prs p "" `shouldParse` succ n++  describe "makeExprParser" $+    it "works" $+      property $ \a' c' v -> do+        let (a,b,c) = getChars v+            p = makePermParser+              ((,,) <$?> (a' :: String, some (char a))+                <||> char b+                <|?> (c', char c))+            bis  = elemIndices b s+            preb = take (bis !! 1) s+            cis  = elemIndices c s+            prec = take (cis !! 1) s+            s    = getInput v+        if | length bis > 1 && (length cis <= 1 || head bis < head cis) ->+               prs_ p s `shouldFailWith` err (posN (bis !! 1) s)+                 ( utok b <> eeof <>+                   (if a `elem` preb then mempty else etok a) <>+                   (if c `elem` preb then mempty else etok c) )+           | length cis > 1 ->+               prs_ p s `shouldFailWith` err (posN (cis !! 1) s)+                 ( utok c <>+                   (if a `elem` prec then mempty else etok a) <>+                   (if b `elem` prec then eeof   else etok b) )+           | b `notElem` s ->+               prs_ p s `shouldFailWith` err (posN (length s) s)+                 ( ueof <> etok b <>+                   (if a `notElem` s || last s == a then etok a else mempty) <>+                   (if c `elem` s then mempty else etok c) )+           | otherwise ->+               prs_ p s `shouldParse`+                 ( if a `elem` s then filter (== a) s else a'+                 , b+                 , if c `elem` s then c else c' )

@@ -0,0 +1,127 @@+--+-- Tests for Megaparsec's textual source positions.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP              #-}+{-# OPTIONS -fno-warn-orphans #-}++module Text.Megaparsec.PosSpec (spec) where++import Data.Function (on)+import Data.List (isInfixOf)+import Data.Semigroup ((<>))+import Test.Hspec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck+import Text.Megaparsec.Pos++#if !MIN_VERSION_base(4,8,0)+import Data.Word (Word)+#endif++spec :: Spec+spec = do++  describe "mkPos" $ do+    context "when the argument is 0" $+      it "throws InvalidPosException" $+        mkPos (0 :: Word) `shouldThrow` (== InvalidPosException)+    context "when the argument is not 0" $+      it "returns Pos with the given value" $+        property $ \n ->+          (n > 0) ==> (mkPos n >>= shouldBe n . unPos)++  describe "unsafePos" $+    context "when the argument is a positive integer" $+      it "returns Pos with the given value" $+        property $ \n ->+          (n > 0) ==> (unPos (unsafePos n) === n)++  describe "Read and Show instances of Pos" $+    it "printed representation of Pos is isomorphic to its value" $+      property $ \x ->+        read (show x) === (x :: Pos)++  describe "Ord instance of Pos" $+    it "works just like Ord instance of underlying Word" $+      property $ \x y ->+        compare x y === (compare `on` unPos) x y++  describe "Semigroup instance of Pos" $+    it "works like addition" $+      property $ \x y ->+        x <> y === unsafePos (unPos x + unPos y) .&&.+        unPos (x <> y) === unPos x + unPos y++  describe "initialPos" $+    it "consturcts initial position correctly" $+      property $ \path ->+        let x = initialPos path+        in sourceName   x === path        .&&.+           sourceLine   x === unsafePos 1 .&&.+           sourceColumn x === unsafePos 1++  describe "Read and Show instances of SourcePos" $+    it "printed representation of SourcePos in isomorphic to its value" $+      property $ \x ->+        read (show x) === (x :: SourcePos)++  describe "sourcePosPretty" $ do+    it "displays file name" $+      property $ \x ->+        sourceName x `isInfixOf` sourcePosPretty x+    it "displays line number" $+      property $ \x ->+        (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x+    it "displays column number" $+      property $ \x ->+        (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x++  describe "defaultUpdatePos" $ do+    it "returns actual position unchanged" $+      property $ \w pos ch ->+        fst (defaultUpdatePos w pos ch) === pos+    it "does not change file name" $+      property $ \w pos ch ->+        (sourceName . snd) (defaultUpdatePos w pos ch) === sourceName pos+    context "when given newline character" $+      it "increments line number" $+        property $ \w pos ->+          (sourceLine . snd) (defaultUpdatePos w pos '\n')+            === (sourceLine pos <> pos1)+    context "when given tab character" $+      it "shits column number to next tab position" $+        property $ \w pos ->+          let c  = sourceColumn pos+              c' = (sourceColumn . snd) (defaultUpdatePos w pos '\t')+          in c' > c .&&. (((unPos c' - 1) `rem` unPos w) == 0)+    context "when given character other than newline or tab" $+      it "increments column number by one" $+        property $ \w pos ch ->+          (ch /= '\n' && ch /= '\t') ==>+          (sourceColumn . snd) (defaultUpdatePos w pos ch)+            === (sourceColumn pos <> pos1)

@@ -0,0 +1,1298 @@+--+-- Tests for Megaparsec's primitive parser combinators.+--+-- Copyright © 2015–2016 Megaparsec contributors+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are+-- met:+--+-- * Redistributions of source code must retain the above copyright notice,+--   this list of conditions and the following disclaimer.+--+-- * Redistributions in binary form must reproduce the above copyright+--   notice, this list of conditions and the following disclaimer in the+--   documentation and/or other materials provided with the distribution.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY+-- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+-- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+-- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.++{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiWayIf        #-}+{-# LANGUAGE Rank2Types        #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS -fno-warn-orphans  #-}++module Text.Megaparsec.PrimSpec (spec) where++import Control.Applicative+import Control.Monad.Cont+import Control.Monad.Except+import Control.Monad.Identity+import Control.Monad.Reader+import Data.Char (toUpper, chr)+import Data.Foldable (asum, concat)+import Data.List (isPrefixOf, foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Maybe (fromMaybe)+import Data.Monoid+import Data.Proxy+import Data.Word (Word8)+import Prelude hiding (span, concat)+import Test.Hspec+import Test.Hspec.Megaparsec+import Test.Hspec.Megaparsec.AdHoc+import Test.QuickCheck hiding (label)+import Text.Megaparsec.Char+import Text.Megaparsec.Combinator+import Text.Megaparsec.Error+import Text.Megaparsec.Pos+import Text.Megaparsec.Prim+import Text.Megaparsec.String+import qualified Control.Monad.State.Lazy    as L+import qualified Control.Monad.State.Strict  as S+import qualified Control.Monad.Writer.Lazy   as L+import qualified Control.Monad.Writer.Strict as S+import qualified Data.ByteString.Char8       as B+import qualified Data.ByteString.Lazy.Char8  as BL+import qualified Data.List.NonEmpty          as NE+import qualified Data.Set                    as E+import qualified Data.Text                   as T+import qualified Data.Text.Lazy              as TL++spec :: Spec+spec = do++  describe "non-String instances of Stream" $ do+    context "lazy ByteString" $ do+      it "unconses correctly" $+        property $ \ch' n -> do+          let p  = many (char ch) :: Parsec Dec BL.ByteString String+              s  = replicate (getNonNegative n) ch+              ch = byteToChar ch'+          parse p "" (BL.pack s) `shouldParse` s+      it "updates position like with String" $+        property $ \w pos ch ->+          updatePos (Proxy :: Proxy BL.ByteString) w pos ch `shouldBe`+          updatePos (Proxy :: Proxy String) w pos ch+    context "strict ByteString" $ do+      it "unconses correctly" $+        property $ \ch' n -> do+          let p  = many (char ch) :: Parsec Dec B.ByteString String+              s  = replicate (getNonNegative n) ch+              ch = byteToChar ch'+          parse p "" (B.pack s) `shouldParse` s+      it "updates position like with String" $+        property $ \w pos ch ->+          updatePos (Proxy :: Proxy B.ByteString) w pos ch `shouldBe`+          updatePos (Proxy :: Proxy String) w pos ch+    context "lazy Text" $ do+      it "unconses correctly" $+        property $ \ch n -> do+          let p = many (char ch) :: Parsec Dec TL.Text String+              s = replicate (getNonNegative n) ch+          parse p "" (TL.pack s) `shouldParse` s+      it "updates position like with String" $+        property $ \w pos ch ->+          updatePos (Proxy :: Proxy TL.Text) w pos ch `shouldBe`+          updatePos (Proxy :: Proxy String) w pos ch+    context "strict Text" $ do+      it "unconses correctly" $+        property $ \ch n -> do+          let p = many (char ch) :: Parsec Dec T.Text String+              s = replicate (getNonNegative n) ch+          parse p "" (T.pack s) `shouldParse` s+      it "updates position like with String" $+        property $ \w pos ch ->+          updatePos (Proxy :: Proxy T.Text) w pos ch `shouldBe`+          updatePos (Proxy :: Proxy String) w pos ch++  describe "position in custom stream" $ do++    describe "eof" $+      it "updates position in stream correctly" $+        property $ \st -> (not . null . stateInput) st ==> do+          let p = eof :: CustomParser ()+              h = head (stateInput st)+              apos = let (_:|z) = statePos st in spanStart h :| z+          runParser' p st `shouldBe`+            ( st { statePos = apos }+            , Left (err apos $ utok h <> eeof) )++    describe "token" $+      it "updates position in stream correctly" $+        property $ \st@State {..} span -> do+          let p = pSpan span+              h = head stateInput+              (apos, npos) =+                let z = NE.tail statePos+                in (spanStart h :| z, spanEnd h :| z)+          if | null stateInput -> runParser' p st `shouldBe`+               ( st+               , Left (err statePos $ ueof <> etok span) )+             | spanBody h == spanBody span -> runParser' p st `shouldBe`+               ( st { statePos = npos+                    , stateInput = tail stateInput }+               , Right span )+             | otherwise -> runParser' p st `shouldBe`+               ( st { statePos = apos}+               , Left (err apos $ utok h <> etok span))++    describe "tokens" $+      it "updates position is stream correctly" $+        property $ \st' ts -> forAll (incCoincidence st' ts) $ \st@State {..} -> do+          let p = tokens compareTokens ts :: CustomParser [Span]+              compareTokens x y = spanBody x == spanBody y+              updatePos' = updatePos (Proxy :: Proxy [Span]) stateTabWidth+              il = length . takeWhile id $ zipWith compareTokens stateInput ts+              tl = length ts+              consumed = take il stateInput+              (apos, npos) =+                let (pos:|z) = statePos+                in ( spanStart (head stateInput) :| z+                   , foldl' (\q t -> snd (updatePos' q t)) pos consumed :| z )+          if | null ts -> runParser' p st `shouldBe` (st, Right [])+             | null stateInput -> runParser' p st `shouldBe`+               ( st+               , Left (err statePos $ ueof <> etoks ts) )+             | il == tl -> runParser' p st `shouldBe`+               ( st { statePos   = npos+                    , stateInput = drop (length ts) stateInput }+               , Right consumed )+             | otherwise -> runParser' p st `shouldBe`+               ( st { statePos = apos }+               , Left (err apos $ utoks (take (il + 1) stateInput) <> etoks ts) )++  describe "ParsecT Functor instance" $ do+    it "obeys identity law" $+      property $ \n ->+        prs (fmap id (pure (n :: Int))) "" ===+        prs (id (pure n))               ""+    it "obeys composition law" $+      property $ \n m t ->+        let f = (+ m)+            g = (* t)+        in prs (fmap (f . g) (pure (n :: Int))) "" ===+           prs ((fmap f . fmap g) (pure n))     ""++  describe "ParsecT Applicative instance" $ do+    it "obeys identity law" $+      property $ \n ->+        prs (pure id <*> pure (n :: Int)) "" ===+        prs (pure n) ""+    it "obeys composition law" $+      property $ \n m t ->+        let u = pure (+ m)+            v = pure (* t)+            w = pure (n :: Int)+        in prs (pure (.) <*> u <*> v <*> w) "" ===+           prs (u <*> (v <*> w)) ""+    it "obeys homomorphism law" $+      property $ \x m ->+        let f = (+ m)+        in prs (pure f <*> pure (x :: Int)) "" ===+           prs (pure (f x)) ""+    it "obeys interchange law" $+      property $ \n y ->+        let u = pure (+ n)+        in prs (u <*> pure (y :: Int)) "" ===+           prs (pure ($ y) <*> u) ""+    describe "(<*>)" $+      context "when first parser succeeds without consuming" $+        context "when second parser fails consuming input" $+          it "fails consuming input" $ do+            let p = m <*> n+                m = return (\x -> 'a' : x)+                n = string "bc" <* empty+                s = "bc"+            prs  p s `shouldFailWith` err (posN (4 :: Int) s) mempty+            prs' p s `failsLeaving`   ""+    describe "(*>)" $+      it "works correctly" $+        property $ \n m ->+          let u = pure (+ (m :: Int))+              v = pure (n :: Int)+          in prs (u *> v) "" ===+             prs (pure (const id) <*> u <*> v) ""+    describe "(<*)" $+      it "works correctly" $+        property $ \n m ->+          let u = pure (m :: Int)+              v = pure (+ (n :: Int))+          in prs (u <* v) "" === prs (pure const <*> u <*> v) ""++  describe "ParsecT Alternative instance" $ do++    describe "empty" $+      it "always fails" $+        property $ \n ->+          prs (empty <|> pure n) "" `shouldParse` (n :: Integer)++    describe "(<|>)" $ do+      context "with two strings" $ do+        context "stream begins with the first string" $+          it "parses the string" $+            property $ \s0 s1 s -> not (s1 `isPrefixOf` s0) ==> do+              let s' = s0 ++ s+                  p = string s0 <|> string s1+              prs  p s' `shouldParse` s0+              prs' p s' `succeedsLeaving` s+        context "stream begins with the second string" $+          it "parses the string" $+            property $ \s0 s1 s -> not (s0 `isPrefixOf` s1) && not (s0 `isPrefixOf` s) ==> do+              let s' = s1 ++ s+                  p = string s0 <|> string s1+              prs  p s' `shouldParse` s1+              prs' p s' `succeedsLeaving` s+        context "when stream does not begin with either string" $+          it "signals correct error message" $+            property $ \s0 s1 s -> not (s0 `isPrefixOf` s) && not (s1 `isPrefixOf` s) ==> do+              let p = string s0 <|> string s1+                  z0' = toFirstMismatch (==) s0 s+                  z1' = toFirstMismatch (==) s1 s+              prs  p s `shouldFailWith` err posI+                (etoks s0 <>+                 etoks s1 <>+                 (if null s then ueof else mempty) <>+                 (if null z0' then mempty else utoks z0') <>+                 (if null z1' then mempty else utoks z1'))+      context "with two complex parsers" $ do+        context "when stream begins with matching character" $+          it "parses it" $+            property $ \a b -> a /= b ==> do+              let p = char a <|> (char b *> char a)+                  s = [a]+              prs  p s `shouldParse` a+              prs' p s `succeedsLeaving` ""+        context "when stream begins with only one matching character" $+          it "signals correct parse error" $+            property $ \a b c -> a /= b && a /= c ==> do+              let p = char a <|> (char b *> char a)+                  s = [b,c]+              prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok a)+              prs' p s `failsLeaving` [c]+        context "when stream begins with not matching character" $+          it "signals correct parse error" $+            property $ \a b c -> a /= b && a /= c && b /= c ==> do+              let p = char a <|> (char b *> char a)+                  s = [c,b]+              prs  p s `shouldFailWith` err posI (utok c <> etok a <> etok b)+              prs' p s `failsLeaving` s+        context "when stream is emtpy" $+          it "signals correct parse error" $+            property $ \a b -> do+              let p = char a <|> (char b *> char a)+              prs  p "" `shouldFailWith` err posI (ueof <> etok a <> etok b)+      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"+            bsum = foldl (<|>) empty+            s  = ">>"+        prs p s `shouldBe` prs p' s++    describe "many" $ do+      context "when stream begins with things argument of many parses" $+        it "they are parsed" $+          property $ \a' b' c' -> do+            let [a,b,c] = getNonNegative <$> [a',b',c']+                p = many (char 'a')+                s = abcRow a b c+            prs  p s `shouldParse` replicate a 'a'+            prs' p s `succeedsLeaving` drop a s+      context "when stream does not begin with thing argument of many parses" $+        it "does nothing" $+          property $ \a' b' c' -> do+            let [a,b,c] = getNonNegative <$> [a',b',c']+                p = many (char 'd')+                s = abcRow a b c+            prs  p s `shouldParse` ""+            prs' p s `succeedsLeaving` s+      context "when stream is empty" $+        it "succeeds parsing nothing" $ do+          let p = many (char 'a')+          prs  p "" `shouldParse` ""+      context "when there are two many combinators in a row that parse nothing" $+        it "accumulated hints are reflected in parse error" $ do+          let p = many (char 'a') *> many (char 'b') *> eof+          prs p "c" `shouldFailWith` err posI+            (utok 'c' <> etok 'a' <> etok 'b' <> eeof)++    describe "some" $ do+      context "when stream begins with things argument of some parses" $+        it "they are parsed" $+          property $ \a' b' c' -> do+            let a = getPositive a'+                [b,c] = getNonNegative <$> [b',c']+                p = some (char 'a')+                s = abcRow a b c+            prs  p s `shouldParse` replicate a 'a'+            prs' p s `succeedsLeaving` drop a s+      context "when stream does not begin with thing argument of some parses" $+        it "signals correct parse error" $+          property $ \a' b' c' -> do+            let [a,b,c] = getNonNegative <$> [a',b',c']+                p = some (char 'd')+                s = abcRow a b c ++ "g"+            prs  p s `shouldFailWith` err posI (utok (head s) <> etok 'd')+            prs' p s `failsLeaving` s+      context "when stream is empty" $+        it "signals correct parse error" $+          property $ \ch -> do+            let p = some (char ch)+            prs  p "" `shouldFailWith` err posI (ueof <> etok ch)+    context "optional" $ do+      context "when stream begins with that optional thing" $+        it "parses it" $+          property $ \a b -> do+            let p = optional (char a) <* char b+                s = [a,b]+            prs  p s `shouldParse` Just a+            prs' p s `succeedsLeaving` ""+      context "when stream does not begin with that optional thing" $+        it "succeeds parsing nothing" $+          property $ \a b -> a /= b ==> do+            let p = optional (char a) <* char b+                s = [b]+            prs  p s `shouldParse` Nothing+            prs' p s `succeedsLeaving` ""+      context "when stream is empty" $+        it "succeeds parsing nothing" $+          property $ \a -> do+            let p = optional (char a)+            prs  p "" `shouldParse` Nothing++  describe "ParsecT Monad instance" $ do+    it "satisfies left identity law" $+      property $ \a k' -> do+        let k = return . (+ k')+            p = return (a :: Int) >>= k+        prs p "" `shouldBe` prs (k a) ""+    it "satisfies right identity law" $+      property $ \a -> do+        let m = return (a :: Int)+            p = m >>= return+        prs p "" `shouldBe` prs m ""+    it "satisfies associativity law" $+      property $ \m' k' h' -> do+        let m = return (m' :: Int)+            k = return . (+ k')+            h = return . (* h')+            p = m >>= (\x -> k x >>= h)+            p' = (m >>= k) >>= h+        prs p "" `shouldBe` prs p' ""+    it "fails signals correct parse error" $+      property $ \msg -> do+        let p = fail msg :: Parsec Dec String ()+        prs p "" `shouldFailWith` err posI (cstm (DecFail msg))+    it "pure is the same as return" $+      property $ \n ->+        prs (pure (n :: Int)) "" `shouldBe` prs (return n) ""+    it "(<*>) is the same as ap" $+      property $ \m' k' -> do+        let m = return (m' :: Int)+            k = return (+ k')+        prs (k <*> m) "" `shouldBe` prs (k `ap` m) ""++  describe "ParsecT MonadFail instance" $+    describe "fail" $+      it "signals correct parse error" $+        property $ \s msg -> do+          let p = void (fail msg)+          prs  p s `shouldFailWith` err posI (cstm $ DecFail msg)+          prs' p s `failsLeaving` s++  describe "ParsecT MonadIO instance" $+    it "liftIO works" $+      property $ \n -> do+        let p = liftIO (return n) :: ParsecT Dec String IO Integer+        runParserT p "" "" `shouldReturn` Right n++  describe "ParsecT MonadReader instance" $ do++    describe "ask" $+      it "returns correct value of context" $+        property $ \n -> do+          let p = ask :: ParsecT Dec String (Reader Integer) Integer+          runReader (runParserT p "" "") n `shouldBe` Right n++    describe "local" $+      it "modifies reader context correctly" $+        property $ \n k -> do+          let p = local (+ k) ask :: ParsecT Dec String (Reader Integer) Integer+          runReader (runParserT p "" "") n `shouldBe` Right (n + k)++  describe "ParsecT MonadState instance" $ do++    describe "get" $+      it "returns correct state value" $+        property $ \n -> do+          let p = L.get :: ParsecT Dec String (L.State Integer) Integer+          L.evalState (runParserT p "" "") n `shouldBe` Right n+    describe "put" $+      it "replaces state value" $+        property $ \a b -> do+          let p = L.put b :: ParsecT Dec String (L.State Integer) ()+          L.execState (runParserT p "" "") a `shouldBe` b++  describe "ParsecT MonadCont instance" $++    describe "callCC" $+      it "works properly" $+        property $ \a b -> do+          let p :: ParsecT Dec String (Cont (Either (ParseError Char Dec) Integer)) Integer+              p = callCC $ \e -> when (a > b) (e a) >> return b+          runCont (runParserT p "" "") id `shouldBe` Right (max a b)++  describe "ParsecT MonadError instance" $ do++    describe "throwError" $+      it "throws the error" $+        property $ \a b -> do+          let p :: ParsecT Dec String (Except Integer) Integer+              p = throwError a >> return b+          runExcept (runParserT p "" "") `shouldBe` Left a++    describe "catchError" $+      it "catches the error" $+        property $ \a b -> do+          let p :: ParsecT Dec String (Except Integer) Integer+              p = (throwError a >> return b) `catchError` handler+              handler e = return (e + b)+          runExcept (runParserT p "" "") `shouldBe` Right (Right $ a + b)++  describe "primitive combinators" $ do++    describe "unexpected" $+      it "signals correct parse error" $+        property $ \item -> do+          let p :: MonadParsec Dec String m => m ()+              p = void (unexpected item)+          grs p "" (`shouldFailWith` ParseError+            { errorPos        = posI+            , errorUnexpected = E.singleton item+            , errorExpected   = E.empty+            , errorCustom     = E.empty })++    describe "failure" $+      it "signals correct parse error" $+        property $ \us ps xs -> do+          let p :: MonadParsec Dec String m => m ()+              p = void (failure us ps xs)+          grs p "" (`shouldFailWith` ParseError+            { errorPos        = posI+            , errorUnexpected = us+            , errorExpected   = ps+            , errorCustom     = xs })++    describe "label" $ do+      context "when inner parser succeeds consuming input" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Dec String m => m Char+                  p = label lbl (char a) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+              grs' p s (`failsLeaving` "")+        context "inner parser produces hints" $+          it "replaces the last hint with “rest of <label>”" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Dec String m => m String+                  p = label lbl (many (char a)) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (elabel $ "rest of " ++ lbl))+              grs' p s (`failsLeaving` "")+      context "when inner parser consumes and fails" $+        it "reports parse error without modification" $+          property $ \lbl a b c -> not (null lbl) && b /= c ==> do+            let p :: MonadParsec Dec String m => m Char+                p = label lbl (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` [c])+      context "when inner parser succeeds without consuming" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Dec String m => m Char+                  p = label lbl (return a) <* empty+              grs p "" (`shouldFailWith` err posI mempty)+        context "inner parser produces hints" $+          it "replaces the last hint with given label" $+            property $ \lbl a -> not (null lbl) ==> do+              let p :: MonadParsec Dec String m => m String+                  p = label lbl (many (char a)) <* empty+              grs p "" (`shouldFailWith` err posI (elabel lbl))+      context "when inner parser fails without consuming" $+        it "is mentioned in parse error via its label" $+          property $ \lbl -> not (null lbl) ==> do+            let p :: MonadParsec Dec String m => m ()+                p = label lbl empty+            grs p "" (`shouldFailWith` err posI (elabel lbl))++    describe "hidden" $ do+      context "when inner parser succeeds consuming input" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \a -> do+              let p :: MonadParsec Dec String m => m Char+                  p = hidden (char a) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+              grs' p s (`failsLeaving` "")+        context "inner parser produces hints" $+          it "hides the parser in the error message" $+            property $ \a -> do+              let p :: MonadParsec Dec String m => m String+                  p = hidden (many (char a)) <* empty+                  s = [a]+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+              grs' p s (`failsLeaving` "")+      context "when inner parser consumes and fails" $+        it "reports parse error without modification" $+          property $ \a b c -> b /= c ==> do+            let p :: MonadParsec Dec String m => m Char+                p = hidden (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` [c])+      context "when inner parser succeeds without consuming" $ do+        context "inner parser does not produce any hints" $+          it "collection of hints remains empty" $+            property $ \a -> do+              let p :: MonadParsec Dec String m => m Char+                  p = hidden (return a) <* empty+              grs p "" (`shouldFailWith` err posI mempty)+        context "inner parser produces hints" $+          it "hides the parser in the error message" $+            property $ \a -> do+              let p :: MonadParsec Dec String m => m String+                  p = hidden (many (char a)) <* empty+              grs p "" (`shouldFailWith` err posI mempty)+      context "when inner parser fails without consuming" $+        it "hides the parser in the error message" $ do+          let p :: MonadParsec Dec String m => m ()+              p = hidden empty+          grs p "" (`shouldFailWith` err posI mempty)++    describe "try" $ do+      context "when inner parser succeeds consuming" $+        it "try has no effect" $+          property $ \a -> do+            let p :: MonadParsec Dec String m => m Char+                p = try (char a)+                s = [a]+            grs  p s (`shouldParse` a)+            grs' p s (`succeedsLeaving` "")+      context "when inner parser fails consuming" $+        it "backtracks, it appears as if the parser has not consumed anything" $+          property $ \a b c -> b /= c ==> do+            let p :: MonadParsec Dec String m => m Char+                p = try (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` s)+      context "when inner parser succeeds without consuming" $+        it "try has no effect" $+          property $ \a -> do+            let p :: MonadParsec Dec String m => m Char+                p = try (return a)+            grs p "" (`shouldParse` a)+      context "when inner parser fails without consuming" $+        it "try backtracks parser state anyway" $+          property $ \w -> do+            let p :: MonadParsec Dec String m => m Char+                p = try (setTabWidth w *> empty)+            grs  p "" (`shouldFailWith` err posI mempty)+            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)++    describe "lookAhead" $ do+      context "when inner parser succeeds consuming" $ do+        it "result is returned but parser state is not changed" $+          property $ \a w -> do+            let p :: MonadParsec Dec String m => m Pos+                p = lookAhead (setTabWidth w *> char a) *> getTabWidth+                s = [a]+            grs  p s (`shouldParse` defaultTabWidth)+            grs' p s (`succeedsLeaving` s)+        it "hints are not preserved" $+          property $ \a -> do+            let p :: MonadParsec Dec String m => m String+                p = lookAhead (many (char a)) <* empty+                s = [a]+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)+      context "when inner parser fails consuming" $+        it "error message is reported as usual" $+          property $ \a b c -> b /= c ==> do+            let p :: MonadParsec Dec String m => m Char+                p = lookAhead (char a *> char b)+                s = [a,c]+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+            grs' p s (`failsLeaving` [c])+      context "when inner parser succeeds without consuming" $ do+        it "result is returned but parser state in not changed" $+          property $ \a w -> do+            let p :: MonadParsec Dec String m => m Pos+                p = lookAhead (setTabWidth w *> char a) *> getTabWidth+                s = [a]+            grs  p s (`shouldParse` defaultTabWidth)+            grs' p s (`succeedsLeaving` s)+        it "hints are not preserved" $+          property $ \a b -> a /= b ==> do+            let p :: MonadParsec Dec String m => m String+                p = lookAhead (many (char a)) <* empty+                s = [b]+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)+      context "when inner parser fails without consuming" $+        it "error message is reported as usual" $ do+          let p :: MonadParsec Dec String m => m Char+              p = lookAhead empty+          grs p "" (`shouldFailWith` err posI mempty)++    describe "notFollowedBy" $ do+      context "when inner parser succeeds consuming" $+        it "signals correct parse error" $+          property $ \a w -> do+            let p :: MonadParsec Dec String m => m ()+                p = notFollowedBy (setTabWidth w <* char a)+                s = [a]+            grs  p s (`shouldFailWith` err posI (utok a))+            grs' p s (`failsLeaving` s)+            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+      context "when inner parser fails consuming" $ do+        it "succeeds without consuming" $+          property $ \a b c w -> b /= c ==> do+            let p :: MonadParsec Dec String m => m ()+                p = notFollowedBy (setTabWidth w *> char a *> char b)+                s = [a,c]+            grs' p s (`succeedsLeaving` s)+            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+        it "hints are not preserved" $+          property $ \a b -> a /= b ==> do+            let p :: MonadParsec Dec String m => m ()+                p = notFollowedBy (char b *> many (char a) <* char a) <* empty+                s = [b,b]+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)+      context "when inner parser succeeds without consuming" $+        it "signals correct parse error" $+          property $ \a w -> do+            let p :: MonadParsec Dec String m => m ()+                p = notFollowedBy (setTabWidth w *> return a)+                s = [a]+            grs  p s (`shouldFailWith` err posI (utok a))+            grs' p s (`failsLeaving` s)+            grs' p s ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+      context "when inner parser fails without consuming" $ do+        it "succeeds without consuming" $+          property $ \w -> do+            let p :: MonadParsec Dec String m => m ()+                p = notFollowedBy (setTabWidth w *> empty)+            grs  p "" (`shouldParse` ())+            grs' p "" ((`shouldBe` defaultTabWidth) . stateTabWidth . fst)+        it "hints are not preserved" $+          property $ \a -> do+            let p :: MonadParsec Dec String m => m ()+                p = notFollowedBy (many (char a) <* char a) <* empty+                s = ""+            grs  p s (`shouldFailWith` err posI mempty)+            grs' p s (`failsLeaving` s)++    describe "withRecovery" $ do+      context "when inner parser succeeds consuming" $+        it "the result is returned as usual" $+          property $ \a as -> do+            let p :: MonadParsec Dec String m => m (Maybe Char)+                p = withRecovery (const $ return Nothing) (pure <$> char a)+                s = a : as+            grs  p s (`shouldParse` Just a)+            grs' p s (`succeedsLeaving` as)+      context "when inner parser fails consuming" $ do+        context "when recovering parser succeeds consuming input" $ do+          it "its result is returned and position is advanced" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ string (c : as))+                        (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))+              grs' p s (`succeedsLeaving` "")+          it "hints are not preserved" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ string (c : as))+                        (Right <$> char a <* many (char b) <* char b) <* empty+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (length s) s) mempty)+              grs' p s (`failsLeaving` "")+        context "when recovering parser fails consuming input" $+          it "the original parse error (and state) is reported" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ char c <* empty)+                        (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+              grs' p s (`failsLeaving` (c : as))+        context "when recovering parser succeeds without consuming" $ do+          it "its result is returned (and state)" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (return . Left) (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))+              grs' p s (`succeedsLeaving` (c : as))+          it "original hints are preserved" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (return . Left)+                        (Right <$> char a <* many (char b) <* char b) <* empty+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (etok b))+              grs' p s (`failsLeaving` (c:as))+        context "when recovering parser fails without consuming" $+          it "the original parse error (and state) is reported" $+            property $ \a b c as -> b /= c ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ empty)+                        (Right <$> char a <* char b)+                  s = a : c : as+              grs  p s (`shouldFailWith` err (posN (1 :: Int) s) (utok c <> etok b))+              grs' p s (`failsLeaving` (c : as))+      context "when inner parser succeeds without consuming" $+        it "the result is returned as usual" $+          property $ \a s -> do+            let p :: MonadParsec Dec String m => m (Maybe Char)+                p = withRecovery (const $ return Nothing) (return a)+            grs  p s (`shouldParse` a)+            grs' p s (`succeedsLeaving` s)+      context "when inner parser fails without consuming" $ do+        context "when recovering parser succeeds consuming input" $+          it "its result is returned and position is advanced" $+            property $ \a as -> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ string s) empty+                  s = a : as+              grs  p s (`shouldParse` Left (err posI mempty))+              grs' p s (`succeedsLeaving` "")+        context "when recovering parser fails consuming input" $+          it "the original parse error (and state) is reported" $+            property $ \a b as -> a /= b ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ char a <* char b <* empty)+                        (Right <$> empty)+                  s = a : as+              grs  p s (`shouldFailWith` err posI mempty)+              grs' p s (`failsLeaving` s)+        context "when recovering parser succeeds without consuming" $ do+          it "its result is returned (and state)" $+            property $ \s -> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (return . Left) empty+              grs  p s (`shouldParse` Left (err posI mempty))+              grs' p s (`succeedsLeaving` s)+          it "original hints are preserved" $+            property $ \a b as -> a /= b ==> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) String)+                  p = withRecovery (return . Left)+                        (Right <$> many (char a) <* empty) <* empty+                  s = b : as+              grs  p s (`shouldFailWith` err posI (etok a))+              grs' p s (`failsLeaving` s)+        context "when recovering parser fails without consuming" $+          it "the original parse error (and state) is reported" $+            property $ \s -> do+              let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                  p = withRecovery (\e -> Left e <$ empty) empty+              grs  p s (`shouldFailWith` err posI mempty)+              grs' p s (`failsLeaving` s)+      it "works in complex situations too" $+        property $ \a' b' c' -> do+          let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) String)+              p = let g = count' 1 3 . char in v <$>+                withRecovery (\e -> Left e <$ g 'b') (Right <$> g 'a') <*> g 'c'+              v (Right x) y = Right (x ++ y)+              v (Left  m) _ = Left m+              ma = if a < 3 then etok 'a' else mempty+              s = abcRow a b c+              [a,b,c] = getNonNegative <$> [a',b',c']+              f = flip shouldFailWith+              z = flip shouldParse+              r | a == 0 && b == 0 && c == 0 = f (err posI (ueof <> etok 'a'))+                | a == 0 && b == 0 && c >  3 = f (err posI (utok 'c' <> etok 'a'))+                | a == 0 && b == 0           = f (err posI (utok 'c' <> etok 'a'))+                | a == 0 && b >  3           = f (err (posN (3 :: Int) s) (utok 'b' <> etok 'a' <> etok 'c'))+                | a == 0 &&           c == 0 = f (err (posN b s) (ueof <> etok 'a' <> etok 'c'))+                | a == 0 &&           c >  3 = f (err (posN (b + 3) s) (utok 'c' <> eeof))+                | a == 0                     = z (Left (err posI (utok 'b' <> etok 'a')))+                | a >  3                     = f (err (posN (3 :: Int) s) (utok 'a' <> etok 'c'))+                |           b == 0 && c == 0 = f (err (posN a s) (ueof <> etok 'c' <> ma))+                |           b == 0 && c >  3 = f (err (posN (a + 3) s) (utok 'c' <> eeof))+                |           b == 0           = z (Right s)+                | otherwise                  = f (err (posN a s) (utok 'b' <> etok 'c' <> ma))+          grs (p <* eof) s r++    describe "observing" $ do+      context "when inner parser succeeds consuming" $+        it "returns its result in Right" $+          property $ \a as -> do+            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                p = observing (char a)+                s = a : as+            grs  p s (`shouldParse` Right a)+            grs' p s (`succeedsLeaving` as)+      context "when inner parser fails consuming" $ do+        it "returns its parse error in Left preserving state" $+          property $ \a b c as -> b /= c ==> do+            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                p = observing (char a *> char b)+                s = a : c : as+            grs  p s (`shouldParse` Left (err (posN (1 :: Int) s) (utok c <> etok b)))+            grs' p s (`succeedsLeaving` (c:as))+        it "does not create any hints" $+          property $ \a b c as -> b /= c ==> do+            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                p = observing (char a *> char b) *> empty+                s = a : c : as+            grs  p s (`shouldFailWith` err (posN (1 :: Int) s) mempty)+            grs' p s (`failsLeaving` (c:as))+      context "when inner parser succeeds without consuming" $+        it "returns its result in Right" $+          property $ \a s -> do+            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                p = observing (return a)+            grs  p s (`shouldParse` Right a)+            grs' p s (`succeedsLeaving` s)+      context "when inner parser fails without consuming" $ do+        it "returns its parse error in Left preserving state" $+          property $ \s -> do+            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) ())+                p = observing empty+            grs  p s (`shouldParse` Left (err posI mempty))+            grs' p s (`succeedsLeaving` s)+        it "creates correct hints" $+          property $ \a b as -> a /= b ==> do+            let p :: MonadParsec Dec String m => m (Either (ParseError Char Dec) Char)+                p = observing (char a) <* empty+                s = b : as+            grs  p s (`shouldFailWith` err posI (etok a))+            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 not empty" $+        it "signals correct error message" $+          property $ \a as -> do+            let s = a : as+            grs  eof s (`shouldFailWith` err posI (utok a <> eeof))+            grs' eof s (`failsLeaving` s)++    describe "token" $ do+      let f x = E.singleton (Tokens $ nes x)+          testChar a x = if x == a then Right x else Left (f x, f a, E.empty)+      context "when supplied predicate is satisfied" $+        it "succeeds" $+          property $ \a as mtok -> do+            let p :: MonadParsec Dec String m => m Char+                p = token (testChar a) mtok+                s = a : as+            grs  p s (`shouldParse` a)+            grs' p s (`succeedsLeaving` as)+      context "when supplied predicate is not satisfied" $+        it "signals correct parse error" $+          property $ \a b as mtok -> a /= b ==> do+            let p :: MonadParsec Dec String m => m Char+                p = token (testChar b) mtok+                s = a : as+            grs  p s (`shouldFailWith` ParseError+              { errorPos        = posI+              , errorUnexpected = E.singleton (Tokens $ nes a)+              , errorExpected   = E.singleton (Tokens $ nes b)+              , errorCustom     = E.empty })+            grs' p s (`failsLeaving` s)+      context "when stream is empty" $+        it "signals correct parse error" $+          property $ \a mtok -> do+            let p :: MonadParsec Dec String m => m Char+                p = token (testChar a) mtok+            grs p "" (`shouldFailWith` ParseError+              { errorPos        = posI+              , errorUnexpected = E.singleton EndOfInput+              , errorExpected   = maybe E.empty (E.singleton . Tokens . nes) mtok+              , errorCustom     = E.empty })++    describe "tokens" $ do+      context "when stream is prefixed with given string" $+        it "parses the string" $+          property $ \str s -> do+            let p :: MonadParsec Dec String m => m String+                p = tokens (==) str+                s' = str ++ s+            grs  p s' (`shouldParse` str)+            grs' p 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 p :: MonadParsec Dec String m => m String+                p = tokens (==) str+                z = toFirstMismatch (==) str s+            grs  p s (`shouldFailWith` err posI (utoks z <> etoks str))+            grs' p s (`failsLeaving` s)++  describe "combinators for manipulating parser state" $ do++    describe "setPosition and getPosition" $+      it "sets position and gets it back" $+        property $ \st pos -> do+          let p :: Parser SourcePos+              p = setPosition pos >> getPosition+              f (State s (_:|xs) w) y = State s (y:|xs) w+          runParser' p st `shouldBe` (f st pos, Right pos)++    describe "pushPosition" $+      it "adds a layer to position stack and parser continues on that level" $+        property $ \st pos ->  do+          let p :: Parser ()+              p = pushPosition pos+          fst (runParser' p st) `shouldBe`+            st { statePos = NE.cons pos (statePos st) }++    describe "popPosition" $+      it "removes a layer from position stack" $+        property $ \st -> do+          let p :: Parser ()+              p = popPosition+              pos = statePos st+          fst (runParser' p st) `shouldBe`+            st { statePos = fromMaybe pos (snd (NE.uncons pos)) }++    describe "setInput and getInput" $+      it "sets input and gets it back" $+        property $ \s -> do+          let p = do+                st0 <- getInput+                guard (null st0)+                setInput s+                result <- string s+                st1 <- getInput+                guard (null st1)+                return result+          prs p "" `shouldParse` s++    describe "setTabWidth and getTabWidth" $+      it "sets tab width and gets it back" $+        property $ \w -> do+          let p = setTabWidth w >> getTabWidth+          prs p "" `shouldParse` w++    describe "setParserState and getParserState" $+      it "sets parser state and gets it back" $+        property $ \s1 s2 -> do+          let p :: MonadParsec Dec String m => m (State String)+              p = do+                st <- getParserState+                guard (st == State s posI defaultTabWidth)+                setParserState s1+                updateParserState (f s2)+                liftM2 const getParserState (setInput "")+              f (State s1' pos w) (State s2' _ _) = State (max s1' s2') pos w+              s = ""+          grs p s (`shouldParse` f s2 s1)++  describe "running a parser" $ do+    describe "parseMaybe" $+      it "returns result on success and Nothing on failure" $+        property $ \s s' -> do+          let p = string s' :: Parser String+          parseMaybe p s `shouldBe`+            if s == s' then Just s else Nothing++    describe "runParser'" $+      it "works" $+        property $ \st s -> do+          let p = string s+          runParser' p st `shouldBe` emulateStrParsing st s++    describe "runParserT'" $+      it "works" $+        property $ \st s -> do+          let p = string s+          runIdentity (runParserT' p st) `shouldBe` emulateStrParsing st s++  describe "MonadParsec instance of ReaderT" $ do++    describe "try" $+      it "generally works" $+        property $ \pre ch1 ch2 -> do+          let s1 = pre : [ch1]+              s2 = pre : [ch2]+              getS1 = asks fst+              getS2 = asks snd+              p = try (g =<< getS1) <|> (g =<< getS2)+              g = sequence . fmap char+              s = [pre]+          prs (runReaderT p (s1, s2)) s `shouldFailWith`+            err (posN (1 :: Int) s) (ueof <> etok ch1 <> etok ch2)++    describe "notFollowedBy" $+      it "generally works" $+        property $ \a' b' c' -> do+          let p = many (char =<< ask) <* notFollowedBy eof <* many anyChar+              [a,b,c] = getNonNegative <$> [a',b',c']+              s = abcRow a b c+          if b > 0 || c > 0+            then prs (runReaderT p 'a') s `shouldParse` replicate a 'a'+            else prs (runReaderT p 'a') s `shouldFailWith`+                   err (posN a s) (ueof <> etok 'a')++  describe "MonadParsec instance of lazy StateT" $ do++    describe "(<|>)" $+      it "generally works" $+        property $ \n -> do+          let p = L.put n >>+                ((L.modify (* 2) >> void (string "xxx")) <|> return ()) >> L.get+          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "lookAhead" $+      it "generally works" $+        property $ \n -> do+          let p = L.put n >> lookAhead (L.modify (* 2) >> eof) >> S.get+          prs (L.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "notFollowedBy" $+      it "generally works" $+        property $ \n -> do+          let p = do+                L.put n+                let notEof = notFollowedBy (L.modify (* 2) >> eof)+                some (try (anyChar <* notEof)) <* char 'x'+          prs (L.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect state" $+          property $ \m n -> do+            let p = do+                  L.put m+                  observing (L.modify (+ n))+            prs (L.execStateT p 0) "" `shouldParse` (m + n :: Integer)+      context "when inner parser fails" $+        it "cannot affect state" $+          property $ \m n -> do+            let p = do+                  L.put m+                  observing (L.modify (+ n) <* empty)+            prs (L.execStateT p 0) "" `shouldParse` (m :: Integer)++  describe "MonadParsec instance of strict StateT" $ do++    describe "(<|>)" $+      it "generally works" $+        property $ \n -> do+          let p = S.put n >>+                ((S.modify (* 2) >> void (string "xxx")) <|> return ()) >> S.get+          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "lookAhead" $+      it "generally works" $+        property $ \n -> do+          let p = S.put n >> lookAhead (S.modify (* 2) >> eof) >> S.get+          prs (S.evalStateT p 0) "" `shouldParse` (n :: Integer)++    describe "notFollowedBy" $+      it "generally works" $+        property $ \n -> do+          let p = do+                S.put n+                let notEof = notFollowedBy (S.modify (* 2) >> eof)+                some (try (anyChar <* notEof)) <* char 'x'+          prs (S.runStateT p 0) "abx" `shouldParse` ("ab", n :: Integer)++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect state" $+          property $ \m n -> do+            let p = do+                  S.put m+                  observing (L.modify (+ n))+            prs (S.execStateT p 0) "" `shouldParse` (m + n :: Integer)+      context "when inner parser fails" $+        it "cannot affect state" $+          property $ \m n -> do+            let p = do+                  S.put m+                  observing (L.modify (+ n) <* empty)+            prs (S.execStateT p 0) "" `shouldParse` (m :: Integer)++  describe "MonadParsec instance of lazy WriterT" $ do++    it "generally works" $+      property $ \pre post -> do+        let loggedLetter = letterChar >>= \x -> L.tell [x] >> return x+            loggedEof    = eof >> L.tell "EOF"+            p = do+              L.tell pre+              cs <- L.censor (fmap toUpper) $+                some (try (loggedLetter <* notFollowedBy loggedEof))+              L.tell post+              void loggedLetter+              return cs+        prs (L.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect log" $+          property $ \n -> do+            let p = observing (L.tell $ Sum n)+            prs (L.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)+      context "when inner parser fails" $+        it "cannot affect log" $+          property $ \n -> do+            let p = observing (L.tell (Sum n) <* empty)+            prs (L.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)++  describe "MonadParsec instance of strict WriterT" $ do++    it "generally works" $+      property $ \pre post -> do+        let loggedLetter = letterChar >>= \x -> S.tell [x] >> return x+            loggedEof    = eof >> S.tell "EOF"+            p = do+              S.tell pre+              cs <- L.censor (fmap toUpper) $+                some (try (loggedLetter <* notFollowedBy loggedEof))+              S.tell post+              void loggedLetter+              return cs+        prs (S.runWriterT p) "abx" `shouldParse` ("ab", pre ++ "AB" ++ post ++ "x")++    describe "observing" $ do+      context "when inner parser succeeds" $+        it "can affect log" $+          property $ \n -> do+            let p = observing (S.tell $ Sum n)+            prs (S.execWriterT p) "" `shouldParse` (Sum n :: Sum Integer)+      context "when inner parser fails" $+        it "cannot affect log" $+          property $ \n -> do+            let p = observing (S.tell (Sum n) <* empty)+            prs (S.execWriterT p) "" `shouldParse` (mempty :: Sum Integer)++  describe "dbg" $ do+    -- NOTE We don't test properties here to avoid flood of debugging output+    -- when the test runs.+    context "when inner parser succeeds consuming input" $ do+      it "has no effect on how parser works" $ do+        let p = dbg "char" (char 'a')+            s = "ab"+        prs  p s `shouldParse` 'a'+        prs' p s `succeedsLeaving` "b"+      it "its hints are preserved" $+        property $ \a b as -> a /= b ==> do+          let p = dbg "many chars" (many (char a)) <* empty+              s = a : b : as+          prs  p s `shouldFailWith` err (posN (1 :: Int) s) (etok a)+          prs' p s `failsLeaving` (b:as)+    context "when inner parser fails consuming input" $+      it "has no effect on how parser works" $ do+        let p = dbg "chars" (char 'a' *> char 'c')+            s = "abc"+        prs  p s `shouldFailWith` err (posN (1 :: Int) s) (utok 'b' <> etok 'c')+        prs' p s `failsLeaving` "bc"+    context "when inner parser succeeds without consuming" $ do+      it "has no effect on how parser works" $ do+        let p = dbg "return" (return 'a')+            s = "abc"+        prs  p s `shouldParse` 'a'+        prs' p s `succeedsLeaving` s+      it "its hints are preserved" $+        property $ \a b as -> a /= b ==> do+          let p = dbg "many chars" (many (char a)) <* empty+              s = b : as+          prs  p s `shouldFailWith` err posI (etok a)+          prs' p s `failsLeaving` (b:as)+    context "when inner parser fails without consuming" $+      it "has no effect on how parser works" $ do+        let p = dbg "empty" (void empty)+            s = "abc"+        prs  p s `shouldFailWith` err posI mempty+        prs' p s `failsLeaving` s++----------------------------------------------------------------------------+-- Helpers++byteToChar :: Word8 -> Char+byteToChar = chr . fromIntegral++-- | This data type represents tokens in custom input stream.++data Span = Span+  { spanStart :: SourcePos+  , spanEnd   :: SourcePos+  , spanBody  :: NonEmpty Char+  } deriving (Eq, Ord, Show)++instance Stream [Span] where+  type Token [Span] = Span+  uncons [] = Nothing+  uncons (t:ts) = Just (t, ts)+  updatePos _ _ _ (Span start end _) = (start, end)++instance Arbitrary Span where+  arbitrary = do+    start <- arbitrary+    end   <- arbitrary `suchThat` (> start)+    Span start end <$>+#if !MIN_VERSION_QuickCheck(2,9,0)+      (NE.fromList . getNonEmpty <$> arbitrary)+#else+      arbitrary+#endif++instance ShowToken Span where+  showTokens ts = concat (NE.toList . spanBody <$> ts)++type CustomParser = Parsec Dec [Span]++pSpan :: Span -> CustomParser Span+pSpan span = token testToken (Just span)+  where+    f = E.singleton . Tokens . nes+    testToken x =+      if spanBody x == spanBody span+        then Right span+        else Left (f x, f span , E.empty)++incCoincidence :: State [Span] -> [Span] -> Gen (State [Span])+incCoincidence st ts = do+  n <- getSmall <$> arbitrary+  let (pre, post) = splitAt n (stateInput st)+      pre' = zipWith (\x t -> x { spanBody = spanBody t }) pre ts+  return st { stateInput = pre' ++ post }++emulateStrParsing+  :: State String+  -> String+  -> (State String, Either (ParseError Char Dec) String)+emulateStrParsing st@(State i (pos:|z) t) s =+  if l == length s+    then (State (drop l i) (updatePosString t pos s :| z) t, Right s)+    else (st, Left $ err (pos:|z) (etoks s <> utoks (take (l + 1) i)))+  where l = length (takeWhile id $ zipWith (==) s i)

@@ -1,367 +0,0 @@------ QuickCheck tests for Megaparsec, utility functions for parser testing.------ Copyright © 2015–2016 Megaparsec contributors------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are--- met:------ * Redistributions of source code must retain the above copyright notice,---   this list of conditions and the following disclaimer.------ * Redistributions in binary form must reproduce the above copyright---   notice, this list of conditions and the following disclaimer in the---   documentation and/or other materials provided with the distribution.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS “AS IS” AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY--- DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS--- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)--- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,--- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN--- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE--- POSSIBILITY OF SUCH DAMAGE.--{-# LANGUAGE CPP              #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes       #-}-{-# OPTIONS -fno-warn-orphans #-}--module Util-  ( checkParser-  , checkParser'-  , checkCase-  , checkCase'-  , simpleParse-  , checkChar-  , checkString-  , updatePosString-  , (/=\)-  , (!=!)-  , abcRow-  , EC (..)-  , posErr-  , posErr'-  , utok-  , utoks-  , ulabel-  , ueof-  , etok-  , etoks-  , elabel-  , eeof-  , cstm )-where--import Control.Monad.Reader-import Control.Monad.Trans.Identity-import Data.Foldable (foldl')-import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (mapMaybe, maybeToList)-import qualified Control.Monad.State.Lazy    as L-import qualified Control.Monad.State.Strict  as S-import qualified Control.Monad.Writer.Lazy   as L-import qualified Control.Monad.Writer.Strict as S-import qualified Data.List.NonEmpty          as NE-import qualified Data.Set                    as E--import Test.QuickCheck-import Test.HUnit (Assertion, (@?=))--import Text.Megaparsec.Error-import Text.Megaparsec.Pos-import Text.Megaparsec.Prim-import Text.Megaparsec.String--#if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>), (<*))-#endif---- | @checkParser p r s@ tries to run parser @p@ on input @s@ to parse--- entire @s@. Result of the parsing is compared with expected result @r@,--- it should match, otherwise the property doesn't hold and the test fails.--checkParser :: (Eq a, Show a)-  => Parser a          -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Property          -- ^ Resulting property-checkParser p r s = simpleParse p s === r---- | A variant of 'checkParser' that runs given parser code with all--- standard instances of 'MonadParsec'. Useful when testing primitive--- combinators.--checkParser' :: (Eq a, Show a)-  => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Property          -- ^ Resulting property-checkParser' p r s = conjoin-  [ checkParser p                   r s-  , checkParser (runIdentityT p)    r s-  , checkParser (runReaderT   p ()) r s-  , checkParser (L.evalStateT p ()) r s-  , checkParser (S.evalStateT p ()) r s-  , checkParser (evalWriterTL p)    r s-  , checkParser (evalWriterTS p)    r s ]---- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead.--checkCase :: (Eq a, Show a)-  => Parser a          -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Assertion         -- ^ Resulting assertion-checkCase p r s = simpleParse p s @?= r---- | Similar to 'checkParser'', but produces HUnit's 'Assertion's instead.--checkCase' :: (Eq a, Show a)-  => (forall m. MonadParsec Dec String m => m a) -- ^ Parser to test-  -> Either (ParseError Char Dec) a -- ^ Expected result of parsing-  -> String            -- ^ Input for the parser-  -> Assertion         -- ^ Resulting assertion-checkCase' p r s = do-  parse p                   "" s @?= r-  parse (runIdentityT p)    "" s @?= r-  parse (runReaderT   p ()) "" s @?= r-  parse (L.evalStateT p ()) "" s @?= r-  parse (S.evalStateT p ()) "" s @?= r-  parse (evalWriterTL p)    "" s @?= r-  parse (evalWriterTS p)    "" s @?= r--evalWriterTL :: Monad m => L.WriterT [Int] m a -> m a-evalWriterTL = liftM fst . L.runWriterT-evalWriterTS :: Monad m => S.WriterT [Int] m a -> m a-evalWriterTS = liftM fst . S.runWriterT---- | @simpleParse p s@ runs parser @p@ on input @s@ and returns corresponding--- result of type @Either ParseError a@, where @a@ is type of parsed--- value. This parser tries to parser end of file too and name of input file--- is always empty string.--simpleParse :: Parser a -> String -> Either (ParseError Char Dec) a-simpleParse p = parse (p <* eof) ""---- | @checkChar p test label s@ runs parser @p@ on input @s@ and checks if--- the parser correctly parses single character that satisfies @test@. The--- character may be labelled, in this case @label@ is used to check quality--- of error messages.--checkChar-  :: Parser Char       -- ^ Parser to run-  -> (Char -> Bool)    -- ^ Predicate to test parsed char-  -> Maybe (ErrorItem Char) -- ^ Representation to use in error messages-  -> String            -- ^ Input stream-  -> Property          -- ^ Resulting property-checkChar p f rep' s = checkParser p r s-  where h = head s-        rep = Expected <$> maybeToList rep'-        r | null s = posErr 0 s (ueof : rep)-          | length s == 1 && f h = Right h-          | not (f h) = posErr 0 s (utok h : rep)-          | otherwise = posErr 1 s [utok (s !! 1), eeof]---- | @checkString p a test label s@ runs parser @p@ on input @s@ and checks if--- the result is equal to @a@ and also quality of error messages. @test@ is--- used to compare tokens. @label@ is used as expected representation of--- parser's result in error messages.--checkString-  :: Parser String     -- ^ Parser to run-  -> String            -- ^ Expected result-  -> (Char -> Char -> Bool) -- ^ Function used to compare tokens-  -> String            -- ^ Input stream-  -> Property-checkString p a' test s' = checkParser p (w a' 0 s') s'-  where w [] _ []    = Right s'-        w [] i (s:_) = posErr i s' [utok s, eeof]-        w _  0 []    = posErr 0 s' [ueof, etoks a']-        w _  i []    = posErr 0 s' [utoks (take i s'), etoks a']-        w (a:as) i (s:ss)-          | test a s  = w as i' ss-          | otherwise = posErr 0 s' [utoks (take i' s'), etoks a']-            where i'  = succ i---- | A helper function that is used to advance 'SourcePos' given a 'String'.--updatePosString-  :: Pos               -- ^ Tab width-  -> SourcePos         -- ^ Initial position-  -> String            -- ^ 'String' — collection of tokens to process-  -> SourcePos         -- ^ Final position-updatePosString w = foldl' f-  where f p t = snd (defaultUpdatePos w p t)--infix 4 /=\   -- preserve whitespace on automatic trim---- | @p /=\\ x@ runs parser @p@ on empty input and compares its result--- (which should be successful) with @x@. Succeeds when the result is equal--- to @x@, prints counterexample on failure.--(/=\) :: (Eq a, Show a) => Parser a -> a -> Property-p /=\ x = simpleParse p "" === Right x--infix 4 !=!---- | @n !=! m@ represents property that holds when results of running @n@--- and @m@ parsers are identical. This is useful when checking monad laws--- for example.--(!=!) :: (Eq a, Show a) => Parser a -> Parser a -> Property-n !=! m = simpleParse n "" === simpleParse m ""---- | @abcRow a b c@ generates string consisting of character “a” repeated--- @a@ times, character “b” repeated @b@ times, and finally character “c”--- repeated @c@ times.--abcRow :: Enum a => a -> a -> a -> String-abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c'-  where f x = replicate (fromEnum x)---- | A component of parse error, useful for fast and dirty construction of--- parse errors with 'posErr' and other helpers.--data EC-  = Unexpected (ErrorItem Char)-  | Expected   (ErrorItem Char)-  | Custom     Dec--instance Arbitrary a => Arbitrary (NonEmpty a) where-  arbitrary = NE.fromList . getNonEmpty <$> arbitrary--instance Arbitrary t => Arbitrary (ErrorItem t) where-  arbitrary = oneof-    [ Tokens <$> arbitrary-    , Label  <$> arbitrary-    , return EndOfInput ]--instance Arbitrary Pos where-  arbitrary = unsafePos . getPositive <$> arbitrary--instance Arbitrary SourcePos where-  arbitrary = SourcePos-    <$> shortString-    <*> (unsafePos <$> choose (1, 1000))-    <*> (unsafePos <$> choose (1,  100))--instance Arbitrary Dec where-  arbitrary = oneof-    [ DecFail        <$> shortString-    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ]--instance (Arbitrary t, Ord t, Arbitrary e, Ord e)-    => Arbitrary (ParseError t e) where-  arbitrary = ParseError-    <$> arbitrary-    <*> arbitrary-    <*> arbitrary-    <*> arbitrary--shortString :: Gen String-shortString = sized $ \n -> do-  k <- choose (0, n `div` 2)-  vectorOf k arbitrary---- | @posErr pos s ms@ is an easy way to model result of parser that fails.--- @pos@ is how many tokens (characters) has been consumed before failure.--- @s@ is input of the parser. @ms@ is a list, collection of 'Message's. See--- 'utok', 'utoks', 'ulabel', 'ueof', 'etok', 'etoks', 'elabel', and 'eeof'--- for easy ways to create error messages.--posErr-  :: Int               -- ^ How many tokens to drop from beginning of steam-  -> String            -- ^ The input stream (just a 'String' here)-  -> [EC]              -- ^ Collection of error components-  -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'-posErr i s = posErr' (pos :| [])-  where pos = updatePosString defaultTabWidth (initialPos "") (take i s)---- | The same as 'posErr', but 'SourcePos' should be provided directly.--posErr'-  :: NonEmpty SourcePos -- ^ Position of the error-  -> [EC]              -- ^ Collection of error components-  -> Either (ParseError Char Dec) a -- ^ 'ParseError' inside of 'Left'-posErr' pos ecs = Left ParseError-  { errorPos        = pos-  , errorUnexpected = E.fromList (mapMaybe getUnexpected ecs)-  , errorExpected   = E.fromList (mapMaybe getExpected   ecs)-  , errorCustom     = E.fromList (mapMaybe getCustom     ecs) }-  where-    getUnexpected (Unexpected x) = Just x-    getUnexpected _              = Nothing-    getExpected   (Expected   x) = Just x-    getExpected   _              = Nothing-    getCustom     (Custom     x) = Just x-    getCustom     _              = Nothing---- | Construct “unexpected token” error component.--utok :: Char -> EC-utok = Unexpected . Tokens . nes---- | Construct “unexpected steam” error component. This function respects--- some conventions described in 'canonicalizeStream'.--utoks :: String -> EC-utoks = Unexpected . canonicalizeStream---- | Construct “unexpected label” error component. Do not use with empty--- strings.--ulabel :: String -> EC-ulabel = Unexpected . Label . NE.fromList---- | Construct “unexpected end of input” error component.--ueof :: EC-ueof = Unexpected EndOfInput---- | Construct “expecting token” error component.--etok :: Char -> EC-etok = Expected . Tokens . nes---- | Construct “expecting stream” error component. This function respects--- some conventions described in 'canonicalizeStream'.--etoks :: String -> EC-etoks = Expected . canonicalizeStream---- | Construct “expecting label” error component. Do not use with empty--- strings.--elabel :: String -> EC-elabel = Expected . Label . NE.fromList---- | Construct “expecting end of input” component.--eeof :: EC-eeof = Expected EndOfInput---- | Construct error component consisting of custom data.--cstm :: Dec -> EC-cstm = Custom---- | Construct appropriate 'MessageItem' representation for given token--- stream. Empty string produces 'EndOfInput', single token — a 'Token', and--- in other cases the 'TokenStream' constructor is used.--canonicalizeStream :: String -> ErrorItem Char-canonicalizeStream stream =-  case NE.nonEmpty stream of-    Nothing      -> EndOfInput-    Just xs      -> Tokens xs---- | Make a singleton non-empty list from a value.--nes :: a -> NonEmpty a-nes x = x :| []-{-# INLINE nes #-}