megaparsec 4.4.0 → 5.0.0

raw patch · 35 files changed

+2409/−1587 lines, 35 filesdep +containersdep +exceptionsdep +scientificdep ~QuickCheckdep ~basedep ~megaparsec

Dependencies added: containers, exceptions, scientific, tagged

Dependency ranges changed: QuickCheck, base, megaparsec

Files

• CHANGELOG.md +105/−0
• README.md +49/−3
• Text/Megaparsec.hs +24/−17
• Text/Megaparsec/ByteString.hs +7/−8
• Text/Megaparsec/ByteString/Lazy.hs +7/−8
• Text/Megaparsec/Char.hs +123/−62
• Text/Megaparsec/Combinator.hs +6/−1
• Text/Megaparsec/Error.hs +184/−153
• Text/Megaparsec/Expr.hs +15/−12
• Text/Megaparsec/Lexer.hs +142/−81
• Text/Megaparsec/Perm.hs +33/−16
• Text/Megaparsec/Pos.hs +129/−113
• Text/Megaparsec/Prim.hs +479/−340
• Text/Megaparsec/ShowToken.hs +0/−53
• Text/Megaparsec/String.hs +6/−7
• Text/Megaparsec/Text.hs +7/−8
• Text/Megaparsec/Text/Lazy.hs +7/−8
• megaparsec.cabal +28/−25
• old-tests/Bugs.hs +0/−1
• old-tests/Bugs/Bug2.hs +0/−1
• old-tests/Bugs/Bug35.hs +3/−2
• old-tests/Bugs/Bug39.hs +1/−0
• old-tests/Bugs/Bug6.hs +4/−5
• old-tests/Bugs/Bug9.hs +2/−0
• old-tests/Main.hs +0/−1
• old-tests/Util.hs +1/−2
• tests/Char.hs +52/−73
• tests/Combinator.hs +37/−38
• tests/Error.hs +88/−91
• tests/Expr.hs +15/−11
• tests/Lexer.hs +143/−75
• tests/Perm.hs +9/−9
• tests/Pos.hs +66/−102
• tests/Prim.hs +444/−181
• tests/Util.hs +193/−80

@@ -1,3 +1,108 @@+## Megaparsec 5.0.0++### General changes++* Removed `parseFromFile` and `StorableStream` type-class that was necessary+  for it. The reason for removal is that reading from file and then parsing+  its contents is trivial for every instance of `Stream` and this function+  provides no way to use newer methods for running a parser, such as+  `runParser'`. So, simply put, it adds little value and was included in 4.x+  versions for compatibility reasons.++* Moved position-advancing function from arguments of `token` and `tokens`+  functions to `Stream` type class (named `updatePos`). The new function+  allows to handle custom streams of tokens where every token contains+  information about its position in stream better (for example when stream+  of tokens is produced with happy/alex).++* Support for include files (stack of positions instead of flat position)+  added. The new functions `pushPosition` and `popPosition` can be used to+  move “vertically” in the stack of positions. `getPosition` and+  `setPosition` still work on top (“current file”) level, but user can get+  full stack via `getParserState` if necessary. Note that `ParseError` and+  pretty-printing for it also support the new feature.++* Added type function `Token` associated with `Stream` type class. The+  function returns type of token corresponding to specific token stream.++* Type `ParsecT` (and also type synonym `Parsec`) are now parametrized over+  type of custom component in parse errors.++* Parameters of `MonadParsec` type class are: `e` — type of custom component+  in parse errors, `s` — type of input stream, and `m` — type of underlying+  monad.++* Type of `failure` primitive combinator was changed, now it accepts three+  arguments: set of unexpected items, set of expected items, and set of+  custom data.++* Type of `token` primitive combinator was changed, now in case of failure a+  triple-tuple is returned with elements corresponding to arguments of+  `failure` primitive. The `token` primitive can also be optionally given an+  argument of token type to use in error messages (as expected item) in case+  of end of input.++* `unexpected` combinator now accepts argument of type `ErrorItem` instead+  of plain `String`.++### Error messages++* The module `Text.Megaparsec.Pos` was completely rewritten. The new module+  uses `Pos` data type with smart constructors to ensure that things like+  line and column number can be only positive. `SourcePos` on the other hand+  does not require smart constructors anymore and its constructors are+  exported. `Show` and `Read` instances of `SourcePos` are derived and+  pretty-printing is done with help of `sourcePosPretty` function.++* The module `Text.Megaparsec.Error` was completely rewritten. A number of+  new types and type-classes are introduced: `ErrorItem`, `Dec`,+  `ErrorComponent`, and `ShowErrorComponent`. `ParseError` does not need+  smart constructors anymore and its constructor and field selectors are+  exported. It uses sets (from the `containers` package) instead of sorted+  lists to enumerate unexpected and expected items. The new definition is+  also parametrized over token type and custom data type which can be passed+  around as part of parse error. Default “custom data” component is `Dec`,+  which see. All in all, we have completely well-typed and extensible error+  messages now. `Show` and `Read` instances of `ParseError` are derived and+  pretty-printing is done with help of `parseErrorPretty`.++* The module `Text.Megaparsec.ShowToken` was eliminated and type class+  `ShowToken` was moved to `Text.Megaparsec.Error`. The only method of that+  class in now named `showTokens` and it works on streams of tokens, where+  single tokes are represented by `NonEmpty` list with single element.++### Built-in combinators++* Combinators `oneOf`, `oneOf'`, `noneOf`, and `noneOf'` now accept any+  instance of `Foldable`, not only `String`.++### Lexer++* Error messages about incorrect indentation levels were greatly improved.+  Now every such message contains information about desired ordering between+  “reference” indentation level and actual indentation level as well as+  values of these levels. The information is stored in `ParseError` in+  well-typed form and can be pretty-printed when necessary. As part of this+  improvement, type of `indentGuard` was changed.++* `incorrectIndent` combinator is introduced in `Text.Megaparsec.Lexer`+  module. It allows to fail with detailed information regarding incorrect+  indentation.++* Introduced `scientific` parser that can parse arbitrary big numbers+  without error or memory overflow. `float` still returns `Double`, but it's+  defined in terms of `scientific` now. Since `Scientific` type can reliably+  represent integer values as well as floating point values, `number` now+  returns `Scientific` instead of `Either Integer Double` (`Integer` or+  `Double` can be extracted from `Scientific` value anyway). This in turn+  makes `signed` parser more natural and general, because we do not need+  ad-hoc `Signed` type class anymore.++* Added `skipBlockCommentNested` function that should help parse possibly+  nested block comments.++* Added `lineFold` function that helps parse line folds.+ ## Megaparsec 4.4.0  * Now state returned on failure is the exact state of parser at the moment

@@ -9,12 +9,15 @@  * [Features](#features)     * [Core features](#core-features)+    * [Error messages](#error-messages)+    * [Alex/Happy support](#alex/happy-support)     * [Character parsing](#character-parsing)     * [Permutation parsing](#permutation-parsing)     * [Expression parsing](#expression-parsing)     * [Lexer](#lexer) * [Documentation](#documentation) * [Tutorials](#tutorials)+* [Performance](#performance) * [Comparison with other solutions](#comparison-with-other-solutions)     * [Megaparsec and Attoparsec](#megaparsec-and-attoparsec)     * [Megaparsec and Parsec](#megaparsec-and-parsec)@@ -91,9 +94,10 @@ * `updateParserState` applies given function on parser state.  This list of core functions is longer than in some other libraries. Our goal-was easy and readable implementation of functionality provided by every such-primitive, not minimal number of them. You can read the comprehensive-description of every primitive function in [Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html).+was efficient and readable implementation of functionality provided by every+such primitive, not minimal number of them. You can read the comprehensive+description of every primitive function in+[Megaparsec documentation](https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec-Prim.html).  Megaparsec can currently work with the following types of input stream: @@ -103,6 +107,29 @@  * `Text` (strict and lazy) +### Error messages++Megaparsec 5 introduces well-typed error messages and ability to use custom+data types to adjust the library to your domain of interest. No need to keep+your info as shapeless bunch of strings anymore.++The default error component (`Dec`) has constructors corresponding to `fail`+function and indentation-related error messages. It is a decent option that+should work out-of-box for most parsing needs, while you are free to use+your own custom error component when necessary with little effort.++This new design allowed Megaparsec 5 to have much more helpful error+messages for indentation-sensitive parsing instead of plain “incorrect+indentation” phrase.++### Alex/Happy support++Megaparsec works well with streams of tokens produced by tools like+Alex/Happy. Megaparsec 5 adds `updatePos` method to `Stream` type class that+gives you full control over textual positions that are used to report token+positions in error messages. You can update current position on per+character basis or extract it from token — all cases are covered.+ ### Character parsing  Megaparsec has decent support for Unicode-aware character parsing. Functions@@ -161,6 +188,10 @@ The design of the module allows you quickly solve simple tasks and doesn't get in your way when you want to implement something less standard. +Since Megaparsec 5, all tools for indentation-sensitive parsing are+available in `Text.Megaparsec.Lexer` module — no third party packages+required.+ ## Documentation  Megaparsec is well-documented. All functions and data-types are thoroughly@@ -175,6 +206,14 @@ should help you to start with your parsing tasks. The site also has instructions and tips for Parsec users who decide to switch. +## Performance++Despite being quite flexible, Megaparsec is also faster than Parsec. The+repository includes benchmarks that can be easily used to compare Megaparsec+and Parsec. In most cases Megaparsec is faster, sometimes dramatically+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.+ ## Comparison with other solutions  There are quite a few libraries that can be used for parsing in Haskell,@@ -226,6 +265,13 @@  * Megaparsec's code is clearer and doesn't contain “magic” found in original   Parsec.++* Megaparsec has well-typed error messages and custom error messages.++* Megaparsec can recover from parse errors “on the fly” and continue+  parsing.++* Megaparsec is faster.  If you want to see a detailed change log, `CHANGELOG.md` may be helpful. 

@@ -10,6 +10,8 @@ -- Portability :  portable -- -- This module includes everything you need to get started writing a parser.+-- If you are new to Megaparsec and don't know where to begin, take a look+-- at our tutorials <https://mrkkrp.github.io/megaparsec/tutorials.html>. -- -- By default this module is set up to parse character data. If you'd like to -- parse the result of your own tokenizer you should start with the following@@ -34,9 +36,10 @@ -- input stream. It just defines useful type-synonym @Parser@. -- -- Megaparsec is capable of a lot. Apart from this standard functionality--- you can parse permutation phrases with "Text.Megaparsec.Perm" and even--- entire languages with "Text.Megaparsec.Lexer". These modules should be--- imported explicitly along with the two modules mentioned above.+-- you can parse permutation phrases with "Text.Megaparsec.Perm",+-- expressions with "Text.Megaparsec.Expr", and even entire languages with+-- "Text.Megaparsec.Lexer". These modules should be imported explicitly+-- along with the two modules mentioned above.  module Text.Megaparsec   ( -- * Running parser@@ -49,7 +52,6 @@   , parse   , parseMaybe   , parseTest-  , parseFromFile     -- * Combinators   , (A.<|>)   -- $assocbo@@ -121,27 +123,32 @@   , satisfy   , string   , string'-    -- * Error messages-  , Message (..)-  , messageString-  , badMessage-  , ParseError-  , errorPos-  , errorMessages-  , errorIsUnknown     -- * Textual source position-  , SourcePos-  , sourceName-  , sourceLine-  , sourceColumn+  , Pos+  , mkPos+  , unPos+  , unsafePos+  , InvalidPosException (..)+  , SourcePos (..)+  , initialPos+  , sourcePosPretty+    -- * Error messages+  , ErrorItem (..)+  , ErrorComponent (..)+  , Dec (..)+  , ParseError (..)+  , ShowToken (..)+  , ShowErrorComponent (..)+  , parseErrorPretty     -- * Low-level operations   , Stream (..)-  , StorableStream (..)   , State (..)   , getInput   , setInput   , getPosition   , setPosition+  , pushPosition+  , popPosition   , getTabWidth   , setTabWidth   , getParserState

@@ -1,23 +1,22 @@ -- | -- Module      :  Text.Megaparsec.ByteString -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Convenience definitions for working with 'B.ByteString'.+-- Convenience definitions for working with strict 'ByteString'.  module Text.Megaparsec.ByteString (Parser) where +import Data.ByteString+import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim-import qualified Data.ByteString as B --- | Different modules corresponding to various types of streams (@String@,--- @Text@, @ByteString@) define it differently, so user can use “abstract”--- @Parser@ type and easily change it by importing different “type--- modules”. This one is for strict byte-strings.+-- | Modules corresponding to various types of streams define 'Parser'+-- accordingly, so user can use it to easily change type of input stream by+-- importing different “type modules”. This one is for strict byte-strings. -type Parser = Parsec B.ByteString+type Parser = Parsec Dec ByteString

@@ -1,23 +1,22 @@ -- | -- Module      :  Text.Megaparsec.ByteString.Lazy -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Convenience definitions for working with lazy 'B.ByteString'.+-- Convenience definitions for working with lazy 'ByteString'.  module Text.Megaparsec.ByteString.Lazy (Parser) where +import Data.ByteString.Lazy+import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim-import qualified Data.ByteString.Lazy as B --- | Different modules corresponding to various types of streams (@String@,--- @Text@, @ByteString@) define it differently, so user can use “abstract”--- @Parser@ type and easily change it by importing different “type--- modules”. This one is for lazy byte-strings.+-- | Modules corresponding to various types of streams define 'Parser'+-- accordingly, so user can use it to easily change type of input stream by+-- importing different “type modules”. This one is for lazy byte-strings. -type Parser = Parsec B.ByteString+type Parser = Parsec Dec ByteString

@@ -11,6 +11,10 @@ -- -- Commonly used character parsers. +{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}+ module Text.Megaparsec.Char   ( -- * Simple parsers     newline@@ -54,17 +58,18 @@  import Control.Applicative ((<|>)) import Data.Char-import Data.List (nub)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromJust)+import qualified Data.Set as E  import Text.Megaparsec.Combinator-import Text.Megaparsec.Error (Message (..))-import Text.Megaparsec.Pos+import Text.Megaparsec.Error import Text.Megaparsec.Prim-import Text.Megaparsec.ShowToken  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), pure)+import Data.Foldable (Foldable (), any, elem, notElem)+import Prelude hiding (any, elem, notElem) #endif  ----------------------------------------------------------------------------@@ -72,34 +77,39 @@  -- | Parses a newline character. -newline :: MonadParsec s m Char => m Char+newline :: (MonadParsec e s m, Token s ~ Char) => m Char newline = char '\n'+{-# INLINE newline #-} --- | Parses a carriage return character followed by a newline--- character. Returns sequence of characters parsed.+-- | Parses a carriage return character followed by a newline character.+-- Returns sequence of characters parsed. -crlf :: MonadParsec s m Char => m String+crlf :: (MonadParsec e s m, Token s ~ Char) => m String crlf = string "\r\n"+{-# INLINE crlf #-} --- | Parses a CRLF (see 'crlf') or LF (see 'newline') end of line.--- Returns the sequence of characters parsed.+-- | Parses a CRLF (see 'crlf') or LF (see 'newline') end of line. Returns+-- the sequence of characters parsed. -- -- > eol = (pure <$> newline) <|> crlf -eol :: MonadParsec s m Char => m String+eol :: (MonadParsec e s m, Token s ~ Char) => m String eol = (pure <$> newline) <|> crlf <?> "end of line"+{-# INLINE eol #-}  -- | Parses a tab character. -tab :: MonadParsec s m Char => m Char+tab :: (MonadParsec e s m, Token s ~ Char) => m Char tab = char '\t'+{-# INLINE tab #-}  -- | Skips /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. -space :: MonadParsec s m Char => m ()+space :: (MonadParsec e s m, Token s ~ Char) => m () space = skipMany spaceChar+{-# INLINE space #-}  ---------------------------------------------------------------------------- -- Categories of characters@@ -107,33 +117,38 @@ -- | Parses control characters, which are the non-printing characters of the -- Latin-1 subset of Unicode. -controlChar :: MonadParsec s m Char => m Char+controlChar :: (MonadParsec e s m, Token s ~ Char) => m Char controlChar = satisfy isControl <?> "control character"+{-# INLINE controlChar #-}  -- | Parses a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. -spaceChar :: MonadParsec s m Char => m Char+spaceChar :: (MonadParsec e s m, Token s ~ Char) => m Char spaceChar = satisfy isSpace <?> "white space"+{-# INLINE spaceChar #-}  -- | Parses an upper-case or title-case alphabetic Unicode character. Title -- case is used by a small number of letter ligatures like the -- single-character form of Lj. -upperChar :: MonadParsec s m Char => m Char+upperChar :: (MonadParsec e s m, Token s ~ Char) => m Char upperChar = satisfy isUpper <?> "uppercase letter"+{-# INLINE upperChar #-}  -- | Parses a lower-case alphabetic Unicode character. -lowerChar :: MonadParsec s m Char => m Char+lowerChar :: (MonadParsec e s m, Token s ~ Char) => m Char lowerChar = satisfy isLower <?> "lowercase letter"+{-# INLINE lowerChar #-}  -- | Parses alphabetic Unicode characters: lower-case, upper-case and -- title-case letters, plus letters of case-less scripts and modifiers -- letters. -letterChar :: MonadParsec s m Char => m Char+letterChar :: (MonadParsec e s m, Token s ~ Char) => m Char letterChar = satisfy isLetter <?> "letter"+{-# INLINE letterChar #-}  -- | Parses alphabetic or numeric digit Unicode characters. --@@ -141,77 +156,90 @@ -- parser but not by 'digitChar'. Such digits may be part of identifiers but -- are not used by the printer and reader to represent numbers. -alphaNumChar :: MonadParsec s m Char => m Char+alphaNumChar :: (MonadParsec e s m, Token s ~ Char) => m Char alphaNumChar = satisfy isAlphaNum <?> "alphanumeric character"+{-# INLINE alphaNumChar #-}  -- | Parses printable Unicode characters: letters, numbers, marks, -- punctuation, symbols and spaces. -printChar :: MonadParsec s m Char => m Char+printChar :: (MonadParsec e s m, Token s ~ Char) => m Char printChar = satisfy isPrint <?> "printable character"+{-# INLINE printChar #-}  -- | Parses an ASCII digit, i.e between “0” and “9”. -digitChar :: MonadParsec s m Char => m Char+digitChar :: (MonadParsec e s m, Token s ~ Char) => m Char digitChar = satisfy isDigit <?> "digit"+{-# INLINE digitChar #-}  -- | Parses an octal digit, i.e. between “0” and “7”. -octDigitChar :: MonadParsec s m Char => m Char+octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char octDigitChar = satisfy isOctDigit <?> "octal digit"+{-# INLINE octDigitChar #-}  -- | Parses a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, -- or “A” and “F”. -hexDigitChar :: MonadParsec s m Char => m Char+hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m Char hexDigitChar = satisfy isHexDigit <?> "hexadecimal digit"+{-# INLINE hexDigitChar #-}  -- | Parses Unicode mark characters, for example accents and the like, which -- combine with preceding characters. -markChar :: MonadParsec s m Char => m Char+markChar :: (MonadParsec e s m, Token s ~ Char) => m Char markChar = satisfy isMark <?> "mark character"+{-# INLINE markChar #-}  -- | Parses Unicode numeric characters, including digits from various -- scripts, Roman numerals, et cetera. -numberChar :: MonadParsec s m Char => m Char+numberChar :: (MonadParsec e s m, Token s ~ Char) => m Char numberChar = satisfy isNumber <?> "numeric character"+{-# INLINE numberChar #-}  -- | Parses Unicode punctuation characters, including various kinds of -- connectors, brackets and quotes. -punctuationChar :: MonadParsec s m Char => m Char+punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m Char punctuationChar = satisfy isPunctuation <?> "punctuation"+{-# INLINE punctuationChar #-}  -- | Parses Unicode symbol characters, including mathematical and currency -- symbols. -symbolChar :: MonadParsec s m Char => m Char+symbolChar :: (MonadParsec e s m, Token s ~ Char) => m Char symbolChar = satisfy isSymbol <?> "symbol"+{-# INLINE symbolChar #-}  -- | Parses Unicode space and separator characters. -separatorChar :: MonadParsec s m Char => m Char+separatorChar :: (MonadParsec e s m, Token s ~ Char) => m Char separatorChar = satisfy isSeparator <?> "separator"+{-# INLINE separatorChar #-}  -- | Parses a character from the first 128 characters of the Unicode character set, -- corresponding to the ASCII character set. -asciiChar :: MonadParsec s m Char => m Char+asciiChar :: (MonadParsec e s m, Token s ~ Char) => m Char asciiChar = satisfy isAscii <?> "ASCII character"+{-# INLINE asciiChar #-}  -- | Parses a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set. -latin1Char :: MonadParsec s m Char => m Char+latin1Char :: (MonadParsec e s m, Token s ~ Char) => m Char latin1Char = satisfy isLatin1 <?> "Latin-1 character"+{-# INLINE latin1Char #-}  -- | @charCategory cat@ Parses character in Unicode General Category @cat@, -- see 'Data.Char.GeneralCategory'. -charCategory :: MonadParsec s m Char => GeneralCategory -> m Char+charCategory :: (MonadParsec e s m, Token s ~ Char) => GeneralCategory -> m Char charCategory cat = satisfy ((== cat) . generalCategory) <?> categoryName cat+{-# INLINE charCategory #-}  -- | Returns human-readable name of Unicode General Category. @@ -256,8 +284,15 @@ -- -- > semicolon = char ';' -char :: MonadParsec s m Char => Char -> m Char-char c = satisfy (== c) <?> showToken c+char :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char+char c = token testChar (Just c)+  where+    f x = E.singleton (Tokens (x:|[]))+    testChar x =+      if x == c+        then Right x+        else Left (f x, f c, E.empty)+{-# INLINE char #-}  -- | The same as 'char' but case-insensitive. This parser returns actually -- parsed character preserving its case.@@ -269,23 +304,20 @@ -- unexpected 'G' -- expecting 'E' or 'e' -char' :: MonadParsec s m Char => Char -> m Char-char' = choice . fmap char . extendi . pure---- | Extends given list of characters adding uppercase version of every--- lowercase characters and vice versa. Resulting list is guaranteed to have--- no duplicates.--extendi :: String -> String-extendi cs = nub (cs >>= f)-  where f c | isLower c = [c, toUpper c]-            | isUpper c = [c, toLower c]-            | otherwise = [c]+char' :: (MonadParsec e s m, Token s ~ Char) => Char -> m Char+char' c = choice [char c, char $ swapCase c]+  where+    swapCase x+      | isUpper x = toLower x+      | isLower x = toUpper x+      | otherwise = x+{-# INLINE char' #-}  -- | This parser succeeds for any character. Returns the parsed character. -anyChar :: MonadParsec s m Char => m Char+anyChar :: (MonadParsec e s m, Token s ~ Char) => m Char anyChar = satisfy (const True) <?> "character"+{-# INLINE anyChar #-}  -- | @oneOf cs@ succeeds if the current character is in the supplied -- list of characters @cs@. Returns the parsed character. Note that this@@ -297,30 +329,34 @@ -- -- > digit = oneOf ['0'..'9'] <?> "digit" -oneOf :: MonadParsec s m Char => String -> m Char+oneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char oneOf cs = satisfy (`elem` cs)+{-# INLINE oneOf #-}  -- | The same as 'oneOf', but case-insensitive. Returns the parsed character -- preserving its case. -- -- > vowel = oneOf' "aeiou" <?> "vowel" -oneOf' :: MonadParsec s m Char => String -> m Char-oneOf' = oneOf . extendi+oneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char+oneOf' cs = satisfy (`elemi` cs)+{-# INLINE oneOf' #-}  -- | As the dual of 'oneOf', @noneOf cs@ succeeds if the current -- character /not/ in the supplied list of characters @cs@. Returns the -- parsed character. -noneOf :: MonadParsec s m Char => String -> m Char+noneOf :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char noneOf cs = satisfy (`notElem` cs)+{-# INLINE noneOf #-}  -- | The same as 'noneOf', but case-insensitive. -- -- > consonant = noneOf' "aeiou" <?> "consonant" -noneOf' :: MonadParsec s m Char => String -> m Char-noneOf' = noneOf . extendi+noneOf' :: (Foldable f, MonadParsec e s m, Token s ~ Char) => f Char -> m Char+noneOf' cs = satisfy (`notElemi` cs)+{-# INLINE noneOf' #-}  -- | The parser @satisfy f@ succeeds for any character for which the -- supplied function @f@ returns 'True'. Returns the character that is@@ -329,11 +365,14 @@ -- > digitChar = satisfy isDigit <?> "digit" -- > oneOf cs  = satisfy (`elem` cs) -satisfy :: MonadParsec s m Char => (Char -> Bool) -> m Char-satisfy f = token updatePosChar testChar-  where testChar x = if f x-                     then Right x-                     else Left . pure . Unexpected . showToken $ x+satisfy :: (MonadParsec e s m, Token s ~ Char) => (Char -> Bool) -> m Char+satisfy f = token testChar Nothing+  where+    testChar x =+      if f x+        then Right x+        else Left (E.singleton (Tokens (x:|[])), E.empty, E.empty)+{-# INLINE satisfy #-}  ---------------------------------------------------------------------------- -- Sequence of characters@@ -343,8 +382,9 @@ -- -- > divOrMod = string "div" <|> string "mod" -string :: MonadParsec s m Char => String -> m String-string = tokens updatePosString (==)+string :: (MonadParsec e s m, Token s ~ Char) => String -> m String+string = tokens (==)+{-# INLINE string #-}  -- | The same as 'string', but case-insensitive. On success returns string -- cased as actually parsed input.@@ -352,6 +392,27 @@ -- >>> parseTest (string' "foobar") "foObAr" -- "foObAr" -string' :: MonadParsec s m Char => String -> m String-string' = tokens updatePosString test-  where test x y = toLower x == toLower y+string' :: (MonadParsec e s m, Token s ~ Char) => String -> m String+string' = tokens casei+{-# INLINE string' #-}++----------------------------------------------------------------------------+-- Helpers++-- | Case-insensitive equality test for characters.++casei :: Char -> Char -> Bool+casei x y = toLower x == toLower y+{-# INLINE casei #-}++-- | Case-insensitive 'elem'.++elemi :: Foldable f => Char -> f Char -> Bool+elemi = any . casei+{-# INLINE elemi #-}++-- | Case-insensitive 'notElem'.++notElemi :: Foldable f => Char -> f Char -> Bool+notElemi c = not . elemi c+{-# INLINE notElemi #-}

@@ -12,6 +12,8 @@ -- Commonly used generic combinators. Note that all combinators works with -- any 'Alternative' instances. +{-# LANGUAGE CPP #-}+ module Text.Megaparsec.Combinator   ( between   , choice@@ -112,13 +114,15 @@ -- > simpleComment = string "<!--" >> manyTill anyChar (string "-->")  manyTill :: Alternative m => m a -> m end -> m [a]-manyTill p end = ([] <$ end) <|> someTill p end+manyTill p end = go where go = ([] <$ end) <|> ((:) <$> p <*> go)+{-# INLINE manyTill #-}  -- | @someTill p end@ works similarly to @manyTill p end@, but @p@ should -- succeed at least once.  someTill :: Alternative m => m a -> m end -> m [a] someTill p end = (:) <$> p <*> manyTill p end+{-# INLINE someTill #-}  -- | @option x p@ tries to apply parser @p@. If @p@ fails without -- consuming input, it returns the value @x@, otherwise the value returned@@ -152,6 +156,7 @@  sepEndBy :: Alternative m => m a -> m sep -> m [a] sepEndBy p sep = sepEndBy1 p sep <|> pure []+{-# INLINE sepEndBy #-}  -- | @sepEndBy1 p sep@ parses /one/ or more occurrences of @p@, -- separated and optionally ended by @sep@. Returns a list of values

@@ -1,223 +1,254 @@ -- | -- Module      :  Text.Megaparsec.Error -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Parse errors.+-- Parse errors. Current version of Megaparsec supports well-typed errors+-- instead of 'String'-based ones. This gives a lot of flexibility in+-- describing what exactly went wrong as well as a way to return arbitrary+-- data in case of failure. +{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE FlexibleInstances  #-}+ module Text.Megaparsec.Error-  ( Message (..)-  , isUnexpected-  , isExpected-  , isMessage-  , messageString-  , badMessage-  , ParseError-  , errorPos-  , errorMessages-  , errorIsUnknown-  , newErrorMessage-  , newErrorMessages-  , newErrorUnknown-  , addErrorMessage-  , addErrorMessages-  , setErrorMessage-  , setErrorPos-  , mergeError-  , showMessages )+  ( ErrorItem (..)+  , ErrorComponent (..)+  , Dec (..)+  , ParseError (..)+  , ShowToken (..)+  , ShowErrorComponent (..)+  , parseErrorPretty+  , sourcePosStackPretty ) where -import Control.Exception (Exception)-import Data.Foldable (find, concat)+import Control.Monad.Catch+import Data.Data (Data)+import Data.Foldable (concat) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..))-import Data.Maybe (fromMaybe, fromJust)-import Data.Semigroup (Semigroup((<>)))+import Data.Semigroup+import Data.Set (Set) import Data.Typeable (Typeable) import Prelude hiding (concat) 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 Data.Foldable (foldMap)-import Data.Monoid (Monoid(..)) #endif --- | This data type represents parse error messages.--data Message-  = Unexpected !String -- ^ Parser ran into an unexpected token-  | Expected   !String -- ^ What is expected instead-  | Message    !String -- ^ General-purpose error message component-  deriving (Show, Eq, Ord)---- | Check if given 'Message' is created with 'Unexpected' constructor.+-- | Data type that is used to represent “unexpected\/expected” items in+-- parse error. The data type is parametrized over token type @t@. ----- @since 4.4.0+-- @since 5.0.0 -isUnexpected :: Message -> Bool-isUnexpected (Unexpected _) = True-isUnexpected _              = False+data ErrorItem t+  = Tokens (NonEmpty t)      -- ^ Non-empty stream of tokens+  | Label (NonEmpty Char)    -- ^ Label (cannot be empty)+  | EndOfInput               -- ^ End of input+  deriving (Show, Read, Eq, Ord, Data, Typeable) --- | Check if given 'Message' is created with 'Expected' constructor.+-- | 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. ----- @since 4.4.0+-- @since 5.0.0 -isExpected :: Message -> Bool-isExpected (Expected _) = True-isExpected _            = False+class Ord e => ErrorComponent e where --- | Check if given 'Message' is created with 'Message' constructor.------ @since 4.4.0+  -- | Represent message passed to 'fail' in parser monad.+  --+  -- @since 5.0.0 -isMessage :: Message -> Bool-isMessage (Message _) = True-isMessage _           = False+  representFail :: String -> e --- | Extract the message string from an error message.+  -- | Represent information about incorrect indentation.+  --+  -- @since 5.0.0 -messageString :: Message -> String-messageString (Unexpected s) = s-messageString (Expected   s) = s-messageString (Message    s) = s+  representIndentation+    :: Ordering -- ^ Desired ordering between reference level and actual level+    -> Pos             -- ^ Reference indentation level+    -> Pos             -- ^ Actual indentation level+    -> e --- | Test if message string is empty.+-- | “Default error component”. This in our instance of 'ErrorComponent'+-- provided out-of-box.+--+-- @since 5.0.0 -badMessage :: Message -> Bool-badMessage = null . messageString+data Dec+  = DecFail String         -- ^ 'fail' has been used in parser monad+  | DecIndentation Ordering Pos Pos -- ^ Incorrect indentation error+  deriving (Show, Read, Eq, Ord, Data, Typeable) +instance ErrorComponent Dec where+  representFail        = DecFail+  representIndentation = DecIndentation+ -- | The data type @ParseError@ represents parse errors. It provides the--- source position ('SourcePos') of the error and a list of error messages--- ('Message').+-- stack of source positions, set of expected and unexpected tokens as well+-- as set of custom associated data. The data type is parametrized over+-- token type @t@ and custom data @e@.+--+-- Note that stack of source positions contains current position as its+-- head, and the rest of positions allows to track full sequence of include+-- files with topmost source file at the end of the list.+--+-- 'Semigroup' (or 'Monoid') instance of the data type allows to merge parse+-- errors from different branches of parsing. When merging two+-- 'ParseError's, longest match is preferred; if positions are the same,+-- custom data sets and collections of message items are combined. -data ParseError = ParseError-  { -- | Extract the source position from 'ParseError'.-    errorPos :: !SourcePos-    -- | Extract the list of error messages from 'ParseError'.-  , errorMessages :: [Message] }-  deriving (Eq, Typeable)+data ParseError t e = ParseError+  { errorPos        :: NonEmpty SourcePos -- ^ Stack of source positions+  , errorUnexpected :: Set (ErrorItem t)  -- ^ Unexpected items+  , errorExpected   :: Set (ErrorItem t)  -- ^ Expected items+  , errorCustom     :: Set e              -- ^ Associated data, if any+  } deriving (Show, Read, Eq, Typeable) -instance Show ParseError where-  show e = show (errorPos e) ++ ":\n" ++ showMessages (errorMessages e)+instance (Ord t, Ord e) => Semigroup (ParseError t e) where+  (<>) = mergeError+  {-# INLINE (<>) #-} -instance Monoid ParseError where-  mempty  = newErrorUnknown (initialPos "")+instance (Ord t, Ord e) => Monoid (ParseError t e) where+  mempty  = ParseError (initialPos "" :| []) E.empty E.empty E.empty   mappend = (<>)+  {-# INLINE mappend #-} -instance Semigroup ParseError where-  (<>) = mergeError+instance (Show t, Typeable t, Show e, Typeable e) => Exception (ParseError t e) -instance Exception ParseError+-- | 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'+-- is only used to merge error messages of alternative branches of parsing+-- and in this case longest match should be preferred. --- | Test whether given 'ParseError' has associated collection of error--- messages. Return @True@ if it has none and @False@ otherwise.+mergeError :: (Ord t, Ord e)+  => ParseError t e+  -> ParseError t e+  -> ParseError t e+mergeError e1@(ParseError pos1 u1 p1 x1) e2@(ParseError pos2 u2 p2 x2) =+  case pos1 `compare` pos2 of+    LT -> e2+    EQ -> ParseError pos1 (E.union u1 u2) (E.union p1 p2) (E.union x1 x2)+    GT -> e1+{-# INLINE mergeError #-} -errorIsUnknown :: ParseError -> Bool-errorIsUnknown (ParseError _ ms) = null ms+-- | Type class 'ShowToken' includes methods that allow to pretty-print+-- single token as well as stream of tokens. This is used for rendering of+-- error messages. --- | @newErrorMessage m pos@ creates 'ParseError' with message @m@ and--- associated position @pos@. If message @m@ has empty message string, it--- won't be included.+class ShowToken a where -newErrorMessage :: Message -> SourcePos -> ParseError-newErrorMessage m = newErrorMessages [m]+  -- | Pretty-print non-empty stream of tokens. This function is also used+  -- to print single tokens (represented as singleton lists).+  --+  -- @since 5.0.0 --- | @newErrorMessages ms pos@ creates 'ParseError' with messages @ms@ and--- associated position @pos@.------ @since 4.2.0+  showTokens :: NonEmpty a -> String -newErrorMessages :: [Message] -> SourcePos -> ParseError-newErrorMessages ms pos = addErrorMessages ms $ newErrorUnknown pos+instance ShowToken Char where+  showTokens = stringPretty --- | @newErrorUnknown pos@ creates 'ParseError' without any associated--- message but with specified position @pos@.+-- | @stringPretty s@ returns pretty representation of string @s@. This is+-- used when printing string tokens in error messages. -newErrorUnknown :: SourcePos -> ParseError-newErrorUnknown pos = ParseError pos []+stringPretty :: NonEmpty Char -> String+stringPretty (x:|[])      = charPretty x+stringPretty ('\r':|"\n") = "crlf newline"+stringPretty xs           = "\"" ++ NE.toList xs ++ "\"" --- | @addErrorMessage m err@ returns @err@ with message @m@ added. This--- function makes sure that list of messages is always sorted and doesn't--- contain duplicates or messages with empty message strings.+-- | @charPretty ch@ returns user-friendly string representation of given+-- character @ch@, suitable for using in error messages. -addErrorMessage :: Message -> ParseError -> ParseError-addErrorMessage m (ParseError pos ms) =-  ParseError pos $ if badMessage m then ms else pre ++ [m] ++ post-  where pre  = filter (< m) ms-        post = filter (> m) ms+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 x    = "'" ++ [x] ++ "'" --- | @addErrorMessages ms err@ returns @err@ with messages @ms@ added. The--- function is defined in terms of 'addErrorMessage'.+-- | The type class defines how to print custom data component of+-- 'ParseError'. ----- @since 4.2.0+-- @since 5.0.0 -addErrorMessages :: [Message] -> ParseError -> ParseError-addErrorMessages ms err = foldr addErrorMessage err ms+class Ord a => ShowErrorComponent a where --- | @setErrorMessage m err@ returns @err@ with message @m@ added. This--- function also deletes all existing error messages that were created with--- the same constructor as @m@. If message @m@ has empty message string, the--- function does not add the message to the result (it still deletes all--- messages of the same type, though).+  -- | Pretty-print custom data component of 'ParseError'. -setErrorMessage :: Message -> ParseError -> ParseError-setErrorMessage m (ParseError pos ms) =-  if badMessage m then err else addErrorMessage m err-  where err = ParseError pos (filter (not . f) ms)-        f   = fromJust $ find ($ m) [isUnexpected, isExpected, isMessage]+  showErrorComponent :: a -> String --- | @setErrorPos pos err@ returns 'ParseError' identical to @err@, but with--- position @pos@.+instance (Ord t, ShowToken t) => ShowErrorComponent (ErrorItem t) where+  showErrorComponent (Tokens   ts) = showTokens ts+  showErrorComponent (Label label) = NE.toList label+  showErrorComponent EndOfInput    = "end of input" -setErrorPos :: SourcePos -> ParseError -> ParseError-setErrorPos pos (ParseError _ ms) = ParseError pos ms+instance ShowErrorComponent Dec where+  showErrorComponent (DecFail msg) = msg+  showErrorComponent (DecIndentation ord ref actual) =+    "incorrect indentation (got " ++ show (unPos actual) +++    ", should be " ++ p ++ show (unPos ref) ++ ")"+    where p = case ord of+                LT -> "less than "+                EQ -> "equal to "+                GT -> "greater than " --- | Merge two error data structures into one joining their collections of--- messages and preferring longest match. In other words, earlier error--- message is discarded. This may seem counter-intuitive, but @mergeError@--- is only used to merge error messages of alternative branches of parsing--- and in this case longest match should be preferred.+-- | Pretty-print 'ParseError'. Note that rendered 'String' always ends with+-- a newline.+--+-- @since 5.0.0 -mergeError :: ParseError -> ParseError -> ParseError-mergeError e1@(ParseError pos1 _) e2@(ParseError pos2 ms2) =-  case pos1 `compare` pos2 of-    LT -> e2-    EQ -> addErrorMessages ms2 e1-    GT -> e1-{-# INLINE mergeError #-}+parseErrorPretty :: ( Ord t+                    , ShowToken t+                    , 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) ] --- | @showMessages ms@ transforms list of error messages @ms@ into--- their textual representation.+-- | Pretty-print stack of source positions.+--+-- @since 5.0.0 -showMessages :: [Message] -> String-showMessages [] = "unknown parse error"-showMessages ms = tail $ foldMap (fromMaybe "") (zipWith f ns rs)-  where (unexpected,    ms') = span isUnexpected ms-        (expected, messages) = span isExpected   ms'-        f prefix m = (prefix ++) <$> m-        ns = ["\nunexpected ","\nexpecting ","\n"]-        rs = (renderMsgs orList <$> [unexpected, expected]) ++-             [renderMsgs (concat . NE.intersperse "\n") messages]+sourcePosStackPretty :: NonEmpty SourcePos -> String+sourcePosStackPretty ms = concatMap f rest ++ sourcePosPretty pos+  where (pos :| rest') = ms+        rest           = reverse rest'+        f p = "in file included from " ++ sourcePosPretty p ++ ",\n" --- | Render collection of messages. If the collection is empty, return--- 'Nothing', otherwise return textual representation of the messages inside--- 'Just'.+-- | Transforms list of error messages into their textual representation. -renderMsgs-  :: (NonEmpty String -> String) -- ^ Function to combine results-  -> [Message]         -- ^ Collection of messages to render-  -> Maybe String      -- ^ Result, if any--- renderMsgs _ [] = Nothing-renderMsgs f ms = f . fmap messageString <$> NE.nonEmpty ms+messageItemsPretty :: ShowErrorComponent a+  => String            -- ^ Prefix to prepend+  -> Set a             -- ^ Collection of messages+  -> String            -- ^ Result of rendering+messageItemsPretty prefix ts+  | E.null ts = ""+  | otherwise =+    let f = orList . NE.fromList . E.toAscList . E.map showErrorComponent+    in prefix ++ f ts ++ "\n"  -- | Print a pretty list where items are separated with commas and the word -- “or” according to rules of English punctuation.

@@ -9,8 +9,8 @@ -- Stability   :  experimental -- Portability :  non-portable ----- A helper module to parse expressions. Builds a parser given a table of--- operators.+-- A helper module to parse expressions. It can build a parser given a table+-- of operators.  module Text.Megaparsec.Expr   ( Operator (..)@@ -70,17 +70,20 @@ -- >         , [ binary  "+"  (+) -- >           , binary  "-"  (-)  ] ] -- >--- > binary  name f = InfixL  (reservedOp name >> return f)--- > prefix  name f = Prefix  (reservedOp name >> return f)--- > postfix name f = Postfix (reservedOp name >> return f)+-- > binary  name f = InfixL  (f <$ symbol name)+-- > prefix  name f = Prefix  (f <$ symbol name)+-- > postfix name f = Postfix (f <$ symbol name) -makeExprParser :: MonadParsec s m t => m a -> [[Operator m a]] -> m a+makeExprParser :: MonadParsec e s m+  => m a               -- ^ Term parser+  -> [[Operator m a]]  -- ^ Operator table, see 'Operator'+  -> m a               -- ^ Resulting expression parser makeExprParser = foldl addPrecLevel  -- | @addPrecLevel p ops@ adds ability to parse operators in table @ops@ to -- parser @p@. -addPrecLevel :: MonadParsec s m t => m a -> [Operator m a] -> m a+addPrecLevel :: MonadParsec e s m => m a -> [Operator m a] -> m a addPrecLevel term ops =   term' >>= \x -> choice [ras' x, las' x, nas' x, return x] <?> "operator"   where (ras, las, nas, prefix, postfix) = foldr splitOp ([],[],[],[],[]) ops@@ -93,7 +96,7 @@ -- optional prefix and postfix unary operators. Parsers @prefix@ and -- @postfix@ are allowed to fail, in this case 'id' is used. -pTerm :: MonadParsec s m t => m (a -> a) -> m a -> m (a -> a) -> m a+pTerm :: MonadParsec e s m => m (a -> a) -> m a -> m (a -> a) -> m a pTerm prefix term postfix = do   pre  <- option id (hidden prefix)   x    <- term@@ -104,7 +107,7 @@ -- with parser @p@, then returns result of the operator application on @x@ -- and the term. -pInfixN :: MonadParsec s m t => m (a -> a -> a) -> m a -> a -> m a+pInfixN :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a pInfixN op p x = do   f <- op   y <- p@@ -114,7 +117,7 @@ -- with parser @p@, then returns result of the operator application on @x@ -- and the term. -pInfixL :: MonadParsec s m t => m (a -> a -> a) -> m a -> a -> m a+pInfixL :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a pInfixL op p x = do   f <- op   y <- p@@ -125,7 +128,7 @@ -- term with parser @p@, then returns result of the operator application on -- @x@ and the term. -pInfixR :: MonadParsec s m t => m (a -> a -> a) -> m a -> a -> m a+pInfixR :: MonadParsec e s m => m (a -> a -> a) -> m a -> a -> m a pInfixR op p x = do   f <- op   y <- p >>= \r -> pInfixR op p r <|> return r@@ -141,7 +144,7 @@ -- | A helper to separate various operators (binary, unary, and according to -- associativity) and return them in a tuple. -splitOp :: MonadParsec s m t => Operator m a -> Batch m a -> Batch m a+splitOp :: Operator m a -> Batch m a -> Batch m a splitOp (InfixR  op) (r, l, n, pre, post) = (op:r, l, n, pre, post) splitOp (InfixL  op) (r, l, n, pre, post) = (r, op:l, n, pre, post) splitOp (InfixN  op) (r, l, n, pre, post) = (r, l, op:n, pre, post)

@@ -18,6 +18,10 @@ -- -- > import qualified Text.Megaparsec.Lexer as L +{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies     #-}+ module Text.Megaparsec.Lexer   ( -- * White space     space@@ -26,20 +30,23 @@   , symbol'   , skipLineComment   , skipBlockComment+  , skipBlockCommentNested     -- * Indentation   , indentLevel+  , incorrectIndent   , indentGuard   , nonIndented   , IndentOpt (..)   , indentBlock+  , lineFold     -- * Character and string literals   , charLiteral     -- * Numbers-  , Signed (..)   , integer   , decimal   , hexadecimal   , octal+  , scientific   , float   , number   , signed )@@ -48,14 +55,15 @@ import Control.Applicative ((<|>), some, optional) import Control.Monad (void) import Data.Char (readLitChar)+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (listToMaybe, fromMaybe, isJust)-import Prelude hiding (negate)-import qualified Prelude+import Data.Scientific (Scientific, toRealFloat)+import qualified Data.Set as E  import Text.Megaparsec.Combinator+import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim-import Text.Megaparsec.ShowToken import qualified Text.Megaparsec.Char as C  #if !MIN_VERSION_base(4,8,0)@@ -90,7 +98,7 @@ -- to consume any white space before the first lexeme (i.e. at the beginning -- of the file). -space :: MonadParsec s m Char+space :: MonadParsec e s m   => m () -- ^ A parser for a space character (e.g. 'C.spaceChar')   -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment')   -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment')@@ -104,7 +112,7 @@ -- > lexeme  = L.lexeme spaceConsumer -- > integer = lexeme L.integer -lexeme :: MonadParsec s m Char+lexeme :: MonadParsec e s m   => m ()              -- ^ How to consume white space after lexeme   -> m a               -- ^ How to parse actual lexeme   -> m a@@ -125,7 +133,7 @@ -- > colon     = symbol ":" -- > dot       = symbol "." -symbol :: MonadParsec s m Char+symbol :: (MonadParsec e s m, Token s ~ Char)   => m ()              -- ^ How to consume white space after lexeme   -> String            -- ^ String to parse   -> m String@@ -134,7 +142,7 @@ -- | Case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages. -symbol' :: MonadParsec s m Char+symbol' :: (MonadParsec e s m, Token s ~ Char)   => m ()              -- ^ How to consume white space after lexeme   -> String            -- ^ String to parse (case-insensitive)   -> m String@@ -145,7 +153,7 @@ -- consume the newline. Newline is either supposed to be consumed by 'space' -- parser or picked up manually. -skipLineComment :: MonadParsec s m Char+skipLineComment :: (MonadParsec e s m, Token s ~ Char)   => String            -- ^ Line comment prefix   -> m () skipLineComment prefix = p >> void (manyTill C.anyChar n)@@ -155,7 +163,7 @@ -- | @skipBlockComment start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. -skipBlockComment :: MonadParsec s m Char+skipBlockComment :: (MonadParsec e s m, Token s ~ Char)   => String            -- ^ Start of block comment   -> String            -- ^ End of block comment   -> m ()@@ -163,6 +171,20 @@   where p = C.string start         n = C.string end +-- | @skipBlockCommentNested start end@ skips possibly nested block comment+-- starting with @start@ and ending with @end@.+--+-- @since 5.0.0++skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char)+  => String            -- ^ Start of block comment+  -> String            -- ^ End of block comment+  -> m ()+skipBlockCommentNested start end = p >> void (manyTill e n)+  where e = skipBlockCommentNested start end <|> void C.anyChar+        p = C.string start+        n = C.string end+ ---------------------------------------------------------------------------- -- Indentation @@ -174,30 +196,49 @@ -- -- @since 4.3.0 -indentLevel :: MonadParsec s m t => m Int+indentLevel :: MonadParsec e s m => m Pos indentLevel = sourceColumn <$> getPosition --- | @indentGuard spaceConsumer test@ first consumes all white space+-- | Fail reporting incorrect indentation error. The error has attached+-- information:+--+--     * Desired ordering between reference level and actual level+--     * Reference indentation level+--     * Actual indentation level+--+-- @since 5.0.0++incorrectIndent :: MonadParsec e s m+  => Ordering  -- ^ Desired ordering between reference level and actual level+  -> Pos               -- ^ Reference indentation level+  -> Pos               -- ^ Actual indentation level+  -> m a+incorrectIndent ord ref actual = failure E.empty E.empty (E.singleton x)+  where x = representIndentation ord ref actual++-- | @indentGuard spaceConsumer ord ref@ first consumes all white space -- (indentation) with @spaceConsumer@ parser, then it checks column--- position. It should satisfy supplied predicate @test@, otherwise the--- parser fails with error message “incorrect indentation”. On success--- current column position is returned.+-- position. Ordering between current indentation level and reference+-- indentation level @ref@ should be @ord@, otherwise the parser fails. On+-- success current column position is returned. -- -- When you want to parse block of indentation first run this parser with--- predicate like @(> 1)@ — this will make sure you have some--- indentation. Use returned value to check indentation on every subsequent--- line according to syntax of your language.+-- 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+-- language. -indentGuard :: MonadParsec s m Char+indentGuard :: MonadParsec e s m   => m ()              -- ^ How to consume indentation (white space)-  -> (Int -> Bool)     -- ^ Predicate checking indentation level-  -> m Int             -- ^ Current column (indentation level)-indentGuard spc p = do-  spc-  lvl <- indentLevel-  if p lvl-    then return lvl-    else fail ii+  -> Ordering -- ^ Desired ordering between reference level and actual level+  -> Pos               -- ^ Reference indentation level+  -> m Pos             -- ^ Current column (indentation level)+indentGuard sc ord ref = do+  sc+  actual <- indentLevel+  if compare actual ref == ord+    then return actual+    else incorrectIndent ord ref actual  -- | Parse non-indented construction. This ensures that there is no -- indentation before actual data. Useful, for example, as a wrapper for@@ -205,11 +246,11 @@ -- -- @since 4.3.0 -nonIndented :: MonadParsec s m Char+nonIndented :: MonadParsec e s m   => m ()              -- ^ How to consume indentation (white space)   -> m a               -- ^ How to parse actual data   -> m a-nonIndented sc p = indentGuard sc (== 1) *> p+nonIndented sc p = indentGuard sc EQ (unsafePos 1) *> p  -- | The data type represents available behaviors for parsing of indented -- tokens. This is used in 'indentBlock', which see.@@ -219,13 +260,13 @@ data IndentOpt m a b   = IndentNone a     -- ^ Parse no indented tokens, just return the value-  | IndentMany (Maybe Int) ([b] -> m a) (m b)+  | IndentMany (Maybe Pos) ([b] -> m a) (m b)     -- ^ Parse many indented tokens (possibly zero), use given indentation     -- level (if 'Nothing', use level of the first indented token); the     -- second argument tells how to get final result, and third argument     -- describes how to parse indented token-  | IndentSome (Maybe Int) ([b] -> m a) (m b)-    -- ^ Just like 'ManyIndent', but requires at least one indented token to+  | IndentSome (Maybe Pos) ([b] -> m a) (m b)+    -- ^ Just like 'IndentMany', but requires at least one indented token to     -- be present  -- | Parse a “reference” token and a number of other tokens that have@@ -239,30 +280,31 @@ -- -- @since 4.3.0 -indentBlock :: MonadParsec s m Char+indentBlock :: (MonadParsec e s m, Token s ~ Char)   => m ()              -- ^ How to consume indentation (white space)   -> m (IndentOpt m a b) -- ^ How to parse “reference” token   -> m a indentBlock sc r = do-  ref <- indentGuard sc (const True)+  sc+  ref <- indentLevel   a   <- r   case a of     IndentNone x -> return x     IndentMany indent f p -> do-      mlvl <- optional . try $ C.eol *> indentGuard sc (> ref)+      mlvl <- optional . try $ C.eol *> indentGuard sc GT ref       case mlvl of         Nothing  -> sc *> f []         Just lvl -> indentedItems ref (fromMaybe lvl indent) sc p >>= f     IndentSome indent f p -> do-      lvl <- C.eol *> indentGuard sc (> ref)+      lvl <- C.eol *> indentGuard sc GT ref       indentedItems ref (fromMaybe lvl indent) sc p >>= f  -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of public API. -indentedItems :: MonadParsec s m Char-  => Int               -- ^ Reference indentation level-  -> Int               -- ^ Level of the first indented item ('lookAhead'ed)+indentedItems :: MonadParsec e s m+  => Pos               -- ^ Reference indentation level+  -> Pos               -- ^ Level of the first indented item ('lookAhead'ed)   -> m ()              -- ^ How to consume indentation (white space)   -> m b               -- ^ How to parse indented tokens   -> m [b]@@ -276,11 +318,33 @@           done <- isJust <$> optional eof           if done             then return []-            else fail ii+            else incorrectIndent EQ lvl pos -ii :: String-ii = "incorrect indentation"+-- | Create a parser that supports line-folding. The first argument is used+-- to consume white space between components of line fold, thus it /must/+-- consume newlines in order to work properly. The second argument is a+-- callback that receives custom space-consuming parser as argument. This+-- parser should be used after separate components of line fold that can be+-- put on different lines.+--+-- An example should clarify the usage pattern:+--+-- > sc = L.space (void spaceChar) empty empty+-- >+-- > myFold = L.lineFold sc $ \sc' -> do+-- >   L.symbol sc' "foo"+-- >   L.symbol sc' "bar"+-- >   L.symbol sc  "baz" -- for the last symbol we use normal space consumer+--+-- @since 5.0.0 +lineFold :: MonadParsec e s m+  => m ()              -- ^ How to consume indentation (white space)+  -> (m () -> m a)     -- ^ Callback that uses provided space-consumer+  -> m a+lineFold sc action =+  sc >> indentLevel >>= action . void . indentGuard sc GT+ ---------------------------------------------------------------------------- -- Character and string literals @@ -298,50 +362,30 @@ -- -- > stringLiteral = char '"' >> manyTill L.charLiteral (char '"') -charLiteral :: MonadParsec s m Char => m Char+charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do   -- The @~@ is needed to avoid requiring a MonadFail constraint,   -- and we do know that r will be non-empty if count' succeeds.   ~r@(x:_) <- lookAhead $ count' 1 8 C.anyChar   case listToMaybe (readLitChar r) of     Just (c, r') -> count (length r - length r') C.anyChar >> return c-    Nothing      -> unexpected (showToken x)+    Nothing      -> unexpected (Tokens (x:|[]))  ---------------------------------------------------------------------------- -- Numbers --- | This type class abstracts the concept of signed number in context of--- this module. This is especially useful when you want to compose 'signed'--- and 'number'.--class Signed a where--  -- | Unary negation.--  negate :: a -> a--instance Signed Integer where-  negate = Prelude.negate--instance Signed Double where-  negate = Prelude.negate--instance (Signed l, Signed r) => Signed (Either l r) where-  negate (Left  x) = Left  $ negate x-  negate (Right x) = Right $ negate x- -- | Parse an integer without sign in decimal representation (according to -- format of integer literals described in Haskell report). -- -- If you need to parse signed integers, see 'signed' combinator. -integer :: MonadParsec s m Char => m Integer+integer :: (MonadParsec e s m, Token s ~ Char) => m Integer integer = decimal <?> "integer"  -- | The same as 'integer', but 'integer' is 'label'ed with “integer” label, -- while this parser is labeled with “decimal integer”. -decimal :: MonadParsec s m Char => m Integer+decimal :: (MonadParsec e s m, Token s ~ Char) => m Integer decimal = nump "" C.digitChar <?> "decimal integer"  -- | Parse an integer in hexadecimal representation. Representation of@@ -354,7 +398,7 @@ -- -- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal -hexadecimal :: MonadParsec s m Char => m Integer+hexadecimal :: (MonadParsec e s m, Token s ~ Char) => m Integer hexadecimal = nump "0x" C.hexDigitChar <?> "hexadecimal integer"  -- | Parse an integer in octal representation. Representation of octal@@ -363,29 +407,43 @@ -- of the programmer to parse correct prefix before parsing the number -- itself. -octal :: MonadParsec s m Char => m Integer+octal :: (MonadParsec e s m, Token s ~ Char) => m Integer octal = nump "0o" C.octDigitChar <?> "octal integer"  -- | @nump prefix p@ parses /one/ or more characters with @p@ parser, then -- prepends @prefix@ to returned value and tries to interpret the result as -- an integer according to Haskell syntax. -nump :: MonadParsec s m Char => String -> m Char -> m Integer+nump :: MonadParsec e s m => String -> m Char -> m Integer nump prefix baseDigit = read . (prefix ++) <$> some baseDigit --- | Parse a floating point value without sign. Representation of floating--- point value is expected to be according to Haskell report.+-- | Parse 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. ----- If you need to parse signed floats, see 'signed'.+-- This function does not parse sign, if you need to parse signed numbers,+-- see 'signed'.+--+-- @since 5.0.0 -float :: MonadParsec s m Char => m Double-float = label "float" (read <$> f)+scientific :: (MonadParsec e s m, Token s ~ Char) => m Scientific+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+-- defined as:+--+-- > float = toRealFloat <$> scientific++float :: (MonadParsec e s m, Token s ~ Char) => m Double+float = toRealFloat <$> scientific+ -- | This is a helper for 'float' parser. It parses fractional part of -- floating point number, that is, dot and everything after it. -fraction :: MonadParsec s m Char => m String+fraction :: (MonadParsec e s m, Token s ~ Char) => m String fraction = do   void (C.char '.')   d <- some C.digitChar@@ -394,7 +452,7 @@  -- | This helper parses exponent of floating point numbers. -fExp :: MonadParsec s m Char => m String+fExp :: (MonadParsec e s m, Token s ~ Char) => m String fExp = do   expChar <- C.char' 'e'   signStr <- option "" (pure <$> choice (C.char <$> "+-"))@@ -402,10 +460,13 @@   return (expChar : signStr ++ d)  -- | Parse a number: either integer or floating point. The parser can handle--- overlapping grammars graciously.+-- overlapping grammars graciously. Use functions like+-- 'Data.Scientific.floatingOrInteger' from "Data.Scientific" to test and+-- extract integer or real values. -number :: MonadParsec s m Char => m (Either Integer Double)-number = (Right <$> try float) <|> (Left <$> integer) <?> "number"+number :: (MonadParsec e s m, Token s ~ Char) => m Scientific+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@@ -418,11 +479,11 @@ -- > integer       = lexeme L.integer -- > signedInteger = L.signed spaceConsumer integer -signed :: (MonadParsec s m Char, Signed a) => m () -> m a -> m a+signed :: (MonadParsec e s m, Token s ~ Char, Num a) => m () -> m a -> m a signed spc p = ($) <$> option id (lexeme spc sign) <*> p  -- | Parse a sign and return either 'id' or 'negate' according to parsed -- sign. -sign :: (MonadParsec s m Char, Signed a) => m (a -> a)+sign :: (MonadParsec e s m, Token s ~ Char, Num a) => m (a -> a) sign = (C.char '+' *> return id) <|> (C.char '-' *> return negate)

@@ -14,6 +14,7 @@ -- Doaitse Swierstra. Published as a functional pearl at the Haskell -- Workshop 2001. +{-# LANGUAGE CPP                       #-} {-# LANGUAGE ExistentialQuantification #-}  module Text.Megaparsec.Perm@@ -58,7 +59,9 @@ -- >               <||> char 'b' -- >               <|?> ('_', char 'c') -makePermParser :: MonadParsec s m t => PermParser s m a -> m a+makePermParser :: MonadParsec e s m+  => PermParser s m a -- ^ Given permutation parser+  -> m a              -- ^ Normal parser built from it makePermParser (Perm def xs) = choice (fmap branch xs ++ empty)   where empty = case def of                   Nothing -> []@@ -78,16 +81,22 @@ -- by the parsers. The function @f@ gets its parameters in the order in -- which the parsers are specified, but actual input can be in any order. -(<$$>) :: MonadParsec s m t => (a -> b) -> m a -> PermParser s m b+(<$$>) :: MonadParsec e s m+  => (a -> b)          -- ^ Function to use on result of parsing+  -> m a               -- ^ Normal parser+  -> PermParser s m b  -- ^ Permutation parser build from it f <$$> p = newperm f <||> p  -- | The expression @f \<$?> (x, p)@ creates a fresh permutation parser--- consisting of parser @p@. The the final result of the permutation parser--- is the function @f@ applied to the return value of @p@. The parser @p@ is+-- consisting of parser @p@. The final result of the permutation parser is+-- the function @f@ applied to the return value of @p@. The parser @p@ is -- optional — if it cannot be applied, the default value @x@ will be used -- instead. -(<$?>) :: MonadParsec s m t => (a -> b) -> (a, m a) -> PermParser s m b+(<$?>) :: MonadParsec e s m+  => (a -> b)          -- ^ Function to use on result of parsing+  -> (a, m a)          -- ^ Default value and parser+  -> PermParser s m b  -- ^ Permutation parser f <$?> xp = newperm f <|?> xp  -- | The expression @perm \<||> p@ adds parser @p@ to the permutation@@ -95,8 +104,10 @@ -- the optional combinator ('<|?>') instead. Returns a new permutation -- parser that includes @p@. -(<||>) :: MonadParsec s m t-       => PermParser s m (a -> b) -> m a -> PermParser s m b+(<||>) :: MonadParsec e s m+  => PermParser s m (a -> b) -- ^ Given permutation parser+  -> m a               -- ^ Parser to add (should not accept empty input)+  -> PermParser s m b  -- ^ Resulting parser (<||>) = add  -- | The expression @perm \<||> (x, p)@ adds parser @p@ to the@@ -104,26 +115,32 @@ -- applied, the default value @x@ will be used instead. Returns a new -- permutation parser that includes the optional parser @p@. -(<|?>) :: MonadParsec s m t-       => PermParser s m (a -> b) -> (a, m a) -> PermParser s m b+(<|?>) :: MonadParsec e s m+  => PermParser s m (a -> b) -- ^ Given permutation parser+  -> (a, m a)          -- ^ Default value and parser+  -> PermParser s m b  -- ^ Resulting parser perm <|?> (x, p) = addopt perm x p -newperm :: MonadParsec s m t-        => (a -> b) -> PermParser s m (a -> b)+newperm :: (a -> b) -> PermParser s m (a -> b) newperm f = Perm (Just f) [] -add :: MonadParsec s m t => PermParser s m (a -> b) -> m a -> PermParser s m b+add :: MonadParsec e s m => PermParser s m (a -> b) -> m a -> PermParser s m b add perm@(Perm _mf fs) p = Perm Nothing (first : fmap insert fs)   where first = Branch perm p         insert (Branch perm' p') = Branch (add (mapPerms flip perm') p) p' -addopt :: MonadParsec s m t-       => PermParser s m (a -> b) -> a -> m a -> PermParser s m b+addopt :: MonadParsec e s m+  => PermParser s m (a -> b)+  -> a+  -> m a+  -> PermParser s m b addopt perm@(Perm mf fs) x p = Perm (fmap ($ x) mf) (first : fmap insert fs)   where first   = Branch perm p         insert (Branch perm' p') = Branch (addopt (mapPerms flip perm') x p) p' -mapPerms :: MonadParsec s m t-         => (a -> b) -> PermParser s m a -> PermParser s m b+mapPerms :: MonadParsec e s m+  => (a -> b)+  -> PermParser s m a+  -> PermParser s m b mapPerms f (Perm x xs) = Perm (fmap f x) (fmap mapBranch xs)   where mapBranch (Branch perm p) = Branch (mapPerms (f .) perm) p

@@ -1,159 +1,175 @@ -- | -- Module      :  Text.Megaparsec.Pos -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini---                © 1999–2001 Daan Leijen -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Textual source position.+-- Textual source position. The position includes name of file, line number,+-- and column number. List of such positions can be used to model stack of+-- include files. +{-# LANGUAGE CPP                #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TupleSections      #-}+ module Text.Megaparsec.Pos-  ( SourcePos-  , sourceName-  , sourceLine-  , sourceColumn-  , InvalidTextualPosition (..)-  , newPos+  ( -- * Abstract position+    Pos+  , mkPos+  , unPos+  , unsafePos+  , InvalidPosException (..)+    -- * Source position+  , SourcePos (..)   , initialPos-  , incSourceLine-  , incSourceColumn-  , setSourceName-  , setSourceLine-  , setSourceColumn-  , updatePosChar-  , updatePosString+  , sourcePosPretty+    -- * Helpers implementing default behaviors+  , defaultUpdatePos   , defaultTabWidth ) where -import Control.Exception (Exception, throw)-import Data.List (foldl')+import Control.Monad.Catch+import Data.Data (Data)+import Data.Semigroup import Data.Typeable (Typeable)---- | The abstract data type @SourcePos@ represents source positions. It--- contains the name of the source (i.e. file name), a line number and a--- column number. @SourcePos@ is an instance of the 'Show', 'Eq' and 'Ord'--- class.+import Unsafe.Coerce -data SourcePos = SourcePos-  { -- | Extract the name of the source from a source position.-    sourceName   :: !String-    -- | Extract the line number from a source position.-  , sourceLine   :: !Int-    -- | Extract the column number from a source position.-  , sourceColumn :: !Int }-  deriving (Eq, Ord)+#if !MIN_VERSION_base(4,8,0)+import Control.Applicative ((<$>))+import Data.Word (Word)+#endif -instance Show SourcePos where-  show (SourcePos n l c)-    | null n    = showLC-    | otherwise = n ++ ":" ++ showLC-      where showLC = show l ++ ":" ++ show c+----------------------------------------------------------------------------+-- Abstract position --- | This exception is thrown when some action on 'SourcePos' is performed--- that would make column number or line number inside this data structure--- non-positive.+-- | Positive integer that is used to represent line number, column number,+-- and similar things like indentation level. 'Semigroup' instance can be+-- used to safely and purely add 'Pos'es together. ----- The 'InvalidTextualPosition' structure includes in order:+-- @since 5.0.0++newtype Pos = Pos Word+  deriving (Show, Eq, Ord, Data, Typeable)++-- | 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+-- get result inside of 'Maybe', for example. -----     * name of file---     * line number (possibly non-positive value)---     * column number (possibly non-positive value)+-- @since 5.0.0 -data InvalidTextualPosition =-  InvalidTextualPosition String Int Int-  deriving (Eq, Show, Typeable)+mkPos :: (Integral a, MonadThrow m) => a -> m Pos+mkPos x =+  if x < 1+    then throwM InvalidPosException+    else (return . Pos . fromIntegral) x+{-# INLINE mkPos #-} -instance Exception InvalidTextualPosition+-- | Dangerous construction of 'Pos'. Use when you know for sure that+-- argument is positive.+--+-- @since 5.0.0 --- | Create a new 'SourcePos' with the given source name, line number and--- column number.+unsafePos :: Word -> Pos+unsafePos x =+  if x < 1+    then error "Text.Megaparsec.Pos.unsafePos"+    else Pos x+{-# INLINE unsafePos #-}++-- | Extract 'Word' from 'Pos'. ----- If line number of column number is not positive, 'InvalidTextualPosition'--- will be thrown.+-- @since 5.0.0 -newPos :: String -- ^ File name-       -> Int    -- ^ Line number, minimum is 1-       -> Int    -- ^ Column number, minimum is 1-       -> SourcePos-newPos n l c =-  if l < 1 || c < 1-  then throw $ InvalidTextualPosition n l c-  else SourcePos n l c+unPos :: Pos -> Word+unPos = unsafeCoerce+{-# INLINE unPos #-} --- | Create a new 'SourcePos' with the given source name, and line number--- and column number set to 1, the upper left.+instance Semigroup Pos where+  (Pos x) <> (Pos y) = Pos (x + y)+  {-# INLINE (<>) #-} -initialPos :: String -> SourcePos-initialPos name = newPos name 1 1+instance Read Pos where+  readsPrec d =+    readParen (d > 10) $ \r1 -> do+      ("Pos", r2) <- lex r1+      (x,     r3) <- readsPrec 11 r2+      (,r3) <$> mkPos (x :: Integer) --- | Increment the line number of a source position. If resulting line--- number is not positive, 'InvalidTextualPosition' will be thrown.+-- | The exception is thrown by 'mkPos' when its argument is not a positive+-- number.+--+-- @since 5.0.0 -incSourceLine :: SourcePos -> Int -> SourcePos-incSourceLine (SourcePos n l c) d = newPos n (l + d) c+data InvalidPosException = InvalidPosException+  deriving (Eq, Show, Data, Typeable) --- | Increment the column number of a source position. If resulting column--- number is not positive, 'InvalidTextualPosition' will be thrown.+instance Exception InvalidPosException -incSourceColumn :: SourcePos -> Int -> SourcePos-incSourceColumn (SourcePos n l c) d = newPos n l (c + d)+----------------------------------------------------------------------------+-- Source position --- | Set the name of the source.+-- | The data type @SourcePos@ represents source positions. It contains the+-- name of the source file, a line number, and a column number. Source line+-- and column positions change intensively during parsing, so we need to+-- make them strict to avoid memory leaks. -setSourceName :: SourcePos -> String -> SourcePos-setSourceName (SourcePos _ l c) n = newPos n l c+data SourcePos = SourcePos+  { sourceName   :: FilePath -- ^ Name of source file+  , sourceLine   :: !Pos     -- ^ Line number+  , sourceColumn :: !Pos     -- ^ Column number+  } deriving (Show, Read, Eq, Ord) --- | Set the line number of a source position. If the line number is not--- positive, 'InvalidTextualPosition' will be thrown.+-- | Construct initial position (line 1, column 1) given name of source+-- file. -setSourceLine :: SourcePos -> Int -> SourcePos-setSourceLine (SourcePos n _ c) l = newPos n l c+initialPos :: String -> SourcePos+initialPos n = SourcePos n u u+  where u = unsafePos 1 --- | Set the column number of a source position. If the line number is not--- positive, 'InvalidTextualPosition' will be thrown.+-- | Pretty-print a 'SourcePos'.+--+-- @since 5.0.0 -setSourceColumn :: SourcePos -> Int -> SourcePos-setSourceColumn (SourcePos n l _) = newPos n l+sourcePosPretty :: SourcePos -> String+sourcePosPretty (SourcePos n l c)+  | null n    = showLC+  | otherwise = n ++ ":" ++ showLC+  where showLC = show (unPos l) ++ ":" ++ show (unPos c) +----------------------------------------------------------------------------+-- Helpers implementing default behaviors+ -- | Update a source position given a character. The first argument -- specifies tab width. If the character is a newline (\'\\n\') the line -- number is incremented by 1. If the character is a tab (\'\\t\') the--- column number is incremented to the nearest tab position, i.e. @column +--- width - ((column - 1) \`rem\` width)@. In all other cases, the column is--- incremented by 1.------ If given tab width is not positive, 'defaultTabWidth' will be used.--updatePosChar :: Int       -- ^ Tab width-              -> SourcePos -- ^ Initial position-              -> Char      -- ^ Character at the position-              -> SourcePos-updatePosChar width (SourcePos n l c) ch =-  case ch of-    '\n' -> SourcePos n (l + 1) 1-    '\t' -> let w = if width < 1 then defaultTabWidth else width-            in SourcePos n l (c + w - ((c - 1) `rem` w))-    _    -> SourcePos n l (c + 1)---- | The expression @updatePosString pos s@ updates the source position--- @pos@ by calling 'updatePosChar' on every character in @s@, i.e.+-- column number is incremented to the nearest tab position. In all other+-- cases, the column is incremented by 1. ----- > updatePosString width = foldl (updatePosChar width)+-- @since 5.0.0 -updatePosString :: Int       -- ^ Tab width-                -> SourcePos -- ^ Initial position-                -> String    -- ^ String to process-                -> SourcePos-updatePosString w = foldl' (updatePosChar w)+defaultUpdatePos+  :: Pos               -- ^ Tab width+  -> SourcePos         -- ^ Current position+  -> Char              -- ^ Current token+  -> (SourcePos, SourcePos) -- ^ Actual position and incremented position+defaultUpdatePos width apos@(SourcePos n l c) ch = (apos, npos)+  where+    u = unsafePos 1+    w = unPos width+    c' = unPos c+    npos =+      case ch of+        '\n' -> SourcePos n (l <> u) u+        '\t' -> SourcePos n l (unsafePos $ c' + w - ((c' - 1) `rem` w))+        _    -> SourcePos n l (c <> u) --- | Value of tab width used by default. This is used as fall-back by--- 'updatePosChar' and possibly in other cases. Always prefer this constant--- when you want to refer to default tab width because actual value /may/--- change in future. Current value is @8@.+-- | Value of tab width used by default. Always prefer this constant when+-- you want to refer to default tab width because actual value /may/ change+-- in future. Current value is @8@. -defaultTabWidth :: Int-defaultTabWidth = 8+defaultTabWidth :: Pos+defaultTabWidth = unsafePos 8

@@ -7,17 +7,28 @@ -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental--- Portability :  non-portable (MPTC with FD)+-- Portability :  non-portable -- -- The primitive parser combinators. -{-# OPTIONS_HADDOCK not-home #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE FunctionalDependencies     #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}+{-# OPTIONS_HADDOCK not-home            #-}  module Text.Megaparsec.Prim   ( -- * Data types     State (..)   , Stream (..)-  , StorableStream (..)   , Parsec   , ParsecT     -- * Primitive combinators@@ -29,6 +40,8 @@   , setInput   , getPosition   , setPosition+  , pushPosition+  , popPosition   , getTabWidth   , setTabWidth   , setParserState@@ -39,12 +52,10 @@   , runParserT'   , parse   , parseMaybe-  , parseTest-  , parseFromFile )+  , parseTest ) where  import Control.Monad-import qualified Control.Monad.Fail as Fail import Control.Monad.Cont.Class import Control.Monad.Error.Class import Control.Monad.Identity@@ -52,24 +63,29 @@ import Control.Monad.State.Class hiding (state) import Control.Monad.Trans import Control.Monad.Trans.Identity+import Data.Foldable (foldl')+import Data.List.NonEmpty (NonEmpty (..))+import Data.Monoid hiding ((<>))+import Data.Proxy import Data.Semigroup-import qualified Control.Applicative as A-import qualified Control.Monad.Trans.Reader as L-import qualified Control.Monad.Trans.State.Lazy as L-import qualified Control.Monad.Trans.State.Strict as S-import qualified Control.Monad.Trans.Writer.Lazy as L+import Data.Set (Set)+import Prelude hiding (all)+import qualified Control.Applicative               as A+import qualified Control.Monad.Fail                as Fail+import qualified Control.Monad.Trans.Reader        as L+import qualified Control.Monad.Trans.State.Lazy    as L+import qualified Control.Monad.Trans.State.Strict  as S+import qualified Control.Monad.Trans.Writer.Lazy   as L import qualified Control.Monad.Trans.Writer.Strict as S--import qualified Data.ByteString.Char8 as B-import qualified Data.ByteString.Lazy.Char8 as BL-import qualified Data.Text as T-import qualified Data.Text.IO as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.IO as TL+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 Text.Megaparsec.Error import Text.Megaparsec.Pos-import Text.Megaparsec.ShowToken  #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>), (<*), pure)@@ -78,32 +94,21 @@ ---------------------------------------------------------------------------- -- Data types --- | This is Megaparsec state, it's parametrized over stream type @s@.+-- | This is Megaparsec's state, it's parametrized over stream type @s@.  data State s = State   { stateInput    :: s-  , statePos      :: !SourcePos-  , stateTabWidth :: !Int }+  , statePos      :: NonEmpty SourcePos+  , stateTabWidth :: Pos }   deriving (Show, Eq) --- | From two states, return the one with greater textual position. If the--- positions are equal, prefer the latter state.--longestMatch :: State s -> State s -> State s-longestMatch s1@(State _ pos1 _) s2@(State _ pos2 _) =-  case pos1 `compare` pos2 of-    LT -> s2-    EQ -> s2-    GT -> s1-{-# INLINE longestMatch #-}- -- | All information available after parsing. This includes consumption of--- input, success (with return value) or failure (with parse error), parser--- state at the end of parsing.+-- input, success (with returned value) or failure (with parse error), and+-- parser state at the end of parsing. -- -- See also: 'Consumption', 'Result'. -data Reply s a = Reply !(State s) Consumption (Result a)+data Reply e s a = Reply (State s) Consumption (Result (Token s) e a)  -- | This data structure represents an aspect of result of parser's -- work.@@ -119,13 +124,13 @@ -- -- See also: 'Consumption', 'Reply'. -data Result a-  = OK a             -- ^ Parser succeeded-  | Error ParseError -- ^ Parser failed+data Result t e a+  = OK a                   -- ^ Parser succeeded+  | Error (ParseError t e) -- ^ Parser failed --- | 'Hints' represent collection of strings to be included into 'ParserError'--- as “expected” messages when a parser fails without consuming input right--- after successful parser that produced the hints.+-- | 'Hints' represent collection of strings to be included into+-- 'ParserError' as “expected” message items when a parser fails without+-- consuming input right after successful parser that produced the hints. -- -- For example, without hints you could get: --@@ -141,106 +146,134 @@ -- unexpected 'a' -- expecting 'r' or end of input -newtype Hints = Hints [[String]] deriving (Monoid, Semigroup)+newtype Hints t = Hints [Set (ErrorItem t)] deriving (Semigroup, Monoid)  -- | Convert 'ParseError' record into 'Hints'. -toHints :: ParseError -> Hints+toHints :: ParseError t e -> Hints t toHints err = Hints hints-  where hints = if null msgs then [] else [messageString <$> msgs]-        msgs  = filter isExpected (errorMessages err)+  where hints = if E.null msgs then [] else [msgs]+        msgs  = errorExpected err+{-# INLINE toHints #-}  -- | @withHints hs c@ makes “error” continuation @c@ use given hints @hs@. ----- Note that if resulting continuation gets 'ParseError' where all messages--- are created with 'Message' constructor, hints are ignored.+-- Note that if resulting continuation gets 'ParseError' that has only+-- custom data in it (no “unexpected” or “expected” items), hints are+-- ignored. -withHints-  :: Hints             -- ^ Hints to use-  -> (ParseError -> State s -> m b) -- ^ Continuation to influence-  -> ParseError        -- ^ First argument of resulting continuation+withHints :: Ord (Token s)+  => Hints (Token s)   -- ^ Hints to use+  -> (ParseError (Token s) e -> State s -> m b) -- ^ Continuation to influence+  -> ParseError (Token s) e -- ^ First argument of resulting continuation   -> State s           -- ^ Second argument of resulting continuation   -> m b-withHints (Hints xs) c e =-  if all isMessage (errorMessages e)+withHints (Hints ps') c e@(ParseError pos us ps xs) =+  if E.null us && E.null ps && not (E.null xs)     then c e-    else c (addErrorMessages (Expected <$> concat xs) e)+    else c (ParseError pos us (E.unions (ps : ps')) xs)+{-# INLINE withHints #-}  -- | @accHints hs c@ results in “OK” continuation that will add given hints -- @hs@ to third argument of original continuation @c@.  accHints-  :: Hints             -- ^ 'Hints' to add-  -> (a -> State s -> Hints -> m b) -- ^ An “OK” continuation to alter+  :: Hints t           -- ^ 'Hints' to add+  -> (a -> State s -> Hints t -> m b) -- ^ An “OK” continuation to alter   -> a                 -- ^ First argument of resulting continuation   -> State s           -- ^ Second argument of resulting continuation-  -> Hints             -- ^ Third argument of resulting continuation+  -> Hints t           -- ^ Third argument of resulting continuation   -> m b accHints hs1 c x s hs2 = c x s (hs1 <> hs2)+{-# INLINE accHints #-} --- | Replace most recent group of hints (if any) with given string. Used in--- 'label' combinator.+-- | Replace most recent group of hints (if any) with given 'ErrorItem' (or+-- delete it if 'Nothing' is given). This is used in 'label' primitive. -refreshLastHint :: Hints -> String -> Hints-refreshLastHint (Hints [])     _  = Hints []-refreshLastHint (Hints (_:xs)) "" = Hints xs-refreshLastHint (Hints (_:xs)) l  = Hints ([l]:xs)+refreshLastHint :: Hints t -> Maybe (ErrorItem t) -> Hints t+refreshLastHint (Hints [])     _        = Hints []+refreshLastHint (Hints (_:xs)) Nothing  = Hints xs+refreshLastHint (Hints (_:xs)) (Just m) = Hints (E.singleton m : xs)+{-# INLINE refreshLastHint #-} --- | An instance of @Stream s t@ has stream type @s@, and token type @t@--- determined by the stream.+-- | An instance of @Stream s@ has stream type @s@. Token type is determined+-- by the stream and can be found via 'Token' type function. -class (ShowToken t, ShowToken [t]) => Stream s t | s -> t where+class Ord (Token s) => Stream s where +  -- | Type of token in stream.+  --+  -- @since 5.0.0++  type Token s :: *+   -- | Get next token from the stream. If the stream is empty, return   -- 'Nothing'. -  uncons :: s -> Maybe (t, s)+  uncons :: s -> Maybe (Token s, s) -instance (ShowToken t, ShowToken [t]) => Stream [t] t where-  uncons []     = Nothing+  -- | Update position in stream given tab width, current position, and+  -- current token. The result is a tuple where the first element will be+  -- used to report parse errors for current token, while the second element+  -- is the incremented position that will be stored in parser's state.+  --+  -- When you work with streams where elements do not contain information+  -- about their position in input, result is usually consists of the third+  -- argument unchanged and incremented position calculated with respect to+  -- current token. This is how default instances of 'Stream' work (they use+  -- 'defaultUpdatePos', which may be a good starting point for your own+  -- position-advancing function).+  --+  -- When you wish to deal with stream of tokens where every token “knows”+  -- its start and end position in input (for example, you have produced the+  -- stream with Happy\/Alex), then the best strategy is to use the start+  -- position as actual element position and provide the end position of the+  -- token as incremented one.+  --+  -- @since 5.0.0++  updatePos+    :: Proxy s -- ^ Proxy clarifying stream type ('Token' is not injective)+    -> Pos             -- ^ Tab width+    -> SourcePos       -- ^ Current position+    -> Token s         -- ^ Current token+    -> (SourcePos, SourcePos) -- ^ Actual position and incremented position++instance Stream String where+  type Token String = Char+  uncons [] = Nothing   uncons (t:ts) = Just (t, ts)   {-# INLINE uncons #-}+  updatePos = const defaultUpdatePos+  {-# INLINE updatePos #-} -instance Stream B.ByteString Char where+instance Stream B.ByteString where+  type Token B.ByteString = Char   uncons = B.uncons   {-# INLINE uncons #-}+  updatePos = const defaultUpdatePos+  {-# INLINE updatePos #-} -instance Stream BL.ByteString Char where+instance Stream BL.ByteString where+  type Token BL.ByteString = Char   uncons = BL.uncons   {-# INLINE uncons #-}+  updatePos = const defaultUpdatePos+  {-# INLINE updatePos #-} -instance Stream T.Text Char where+instance Stream T.Text where+  type Token T.Text = Char   uncons = T.uncons   {-# INLINE uncons #-}+  updatePos = const defaultUpdatePos+  {-# INLINE updatePos #-} -instance Stream TL.Text Char where+instance Stream TL.Text where+  type Token TL.Text = Char   uncons = TL.uncons   {-# INLINE uncons #-}---- | @StorableStream@ abstracts ability of some streams to be stored in a--- file. This is used by the polymorphic function 'parseFromFile'.--class Stream s t => StorableStream s t where--  -- | @fromFile filename@ returns action that will try to read contents of-  -- file named @filename@.--  fromFile :: FilePath -> IO s--instance StorableStream String Char where-  fromFile = readFile--instance StorableStream B.ByteString Char where-  fromFile = B.readFile--instance StorableStream BL.ByteString Char where-  fromFile = BL.readFile--instance StorableStream T.Text Char where-  fromFile = T.readFile--instance StorableStream TL.Text Char where-  fromFile = TL.readFile+  updatePos = const defaultUpdatePos+  {-# INLINE updatePos #-}  -- If you're reading this, you may be interested in how Megaparsec works on -- lower level. That's quite simple. 'ParsecT' is a wrapper around function@@ -275,39 +308,52 @@ -- | @Parsec@ is non-transformer variant of more general 'ParsecT' -- monad transformer. -type Parsec s = ParsecT s Identity+type Parsec e s = ParsecT e s Identity --- | @ParsecT s m a@ is a parser with stream type @s@, underlying monad @m@--- and return type @a@.+-- | @ParsecT e s m a@ is a parser with custom data component of error @e@,+-- stream type @s@, underlying monad @m@ and return type @a@. -newtype ParsecT s m a = ParsecT-  { unParser :: forall b. State s-             -> (a -> State s -> Hints -> m b) -- consumed-OK-             -> (ParseError -> State s -> m b) -- consumed-error-             -> (a -> State s -> Hints -> m b) -- empty-OK-             -> (ParseError -> State s -> m b) -- empty-error-             -> m b }+newtype ParsecT e s m a = ParsecT+  { unParser+      :: forall b. State s+      -> (a -> State s   -> Hints (Token s) -> m b) -- consumed-OK+      -> (ParseError (Token s) e -> State s -> m b) -- consumed-error+      -> (a -> State s   -> Hints (Token s) -> m b) -- empty-OK+      -> (ParseError (Token s) e -> State s -> m b) -- empty-error+      -> m b } -instance Functor (ParsecT s m) where+instance Functor (ParsecT e s m) where   fmap = pMap -pMap :: (a -> b) -> ParsecT s m a -> ParsecT s m b+pMap :: (a -> b) -> ParsecT e s m a -> ParsecT e s m b pMap f p = ParsecT $ \s cok cerr eok eerr ->   unParser p s (cok . f) cerr (eok . f) eerr {-# INLINE pMap #-} -instance A.Applicative (ParsecT s m) where+instance (ErrorComponent e, Stream s) => A.Applicative (ParsecT e s m) where   pure     = pPure-  (<*>)    = ap+  (<*>)    = pAp   p1 *> p2 = p1 `pBind` const p2   p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } -instance A.Alternative (ParsecT s m) where+pAp :: Stream s+  => ParsecT e s m (a -> b)+  -> ParsecT e s m a+  -> ParsecT e s m b+pAp m k = ParsecT $ \s cok cerr eok eerr ->+  let mcok x s' hs = unParser k s' (cok . x) cerr+        (accHints hs (cok . x)) (withHints hs cerr)+      meok x s' hs = unParser k s' (cok . x) cerr+        (accHints hs (eok . x)) (withHints hs eerr)+  in unParser m s mcok cerr meok eerr+{-# INLINE pAp #-}++instance (ErrorComponent e, Stream s) => A.Alternative (ParsecT e s m) where   empty  = mzero   (<|>)  = mplus   many p = reverse <$> manyAcc p -manyAcc :: ParsecT s m a -> ParsecT s m [a]+manyAcc :: ParsecT e s m a -> ParsecT e s m [a] manyAcc p = ParsecT $ \s cok cerr eok _ ->   let errToHints c err _ = c (toHints err)       walk xs x s' _ =@@ -323,35 +369,41 @@   "Text.Megaparsec.Prim.many: combinator 'many' is applied to a parser"   ++ " that accepts an empty string." -instance Monad (ParsecT s m) where+instance (ErrorComponent e, Stream s)+    => Monad (ParsecT e s m) where   return = pure   (>>=)  = pBind   fail   = Fail.fail -instance Fail.MonadFail (ParsecT s m) where-  fail   = pFail--pPure :: a -> ParsecT s m a+pPure :: a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-} -pBind :: ParsecT s m a -> (a -> ParsecT s m b) -> ParsecT s m b+pBind :: Stream s+  => ParsecT e s m a+  -> (a -> ParsecT e s m b)+  -> ParsecT e s m b pBind m k = ParsecT $ \s cok cerr eok eerr ->   let mcok x s' hs = unParser (k x) s' cok cerr-                     (accHints hs cok) (withHints hs cerr)+        (accHints hs cok) (withHints hs cerr)       meok x s' hs = unParser (k x) s' cok cerr-                     (accHints hs eok) (withHints hs eerr)+        (accHints hs eok) (withHints hs eerr)   in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} -pFail :: String -> ParsecT s m a+instance (ErrorComponent e, Stream s)+    => Fail.MonadFail (ParsecT e s m) where+  fail = pFail++pFail :: ErrorComponent e => String -> ParsecT e s m a pFail msg = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->-  eerr (newErrorMessage (Message msg) pos) s+  eerr (ParseError pos E.empty E.empty d) s+  where d = E.singleton (representFail msg) {-# INLINE pFail #-}  -- | Low-level creation of the 'ParsecT' type. -mkPT :: Monad m => (State s -> m (Reply s a)) -> ParsecT s m a+mkPT :: Monad m => (State s -> m (Reply e s a)) -> ParsecT e s m a mkPT k = ParsecT $ \s cok cerr eok eerr -> do   (Reply s' consumption result) <- k s   case consumption of@@ -364,38 +416,48 @@         OK    x -> eok x s' mempty         Error e -> eerr e s' -instance MonadIO m => MonadIO (ParsecT s m) where+instance (ErrorComponent e, Stream s, MonadIO m)+    => MonadIO (ParsecT e s m) where   liftIO = lift . liftIO -instance MonadReader r m => MonadReader r (ParsecT s m) where+instance (ErrorComponent e, Stream s, MonadReader r m)+    => MonadReader r (ParsecT e s m) where   ask       = lift ask   local f p = mkPT $ \s -> local f (runParsecT p s) -instance MonadState s m => MonadState s (ParsecT s' m) where+instance (ErrorComponent e, Stream s, MonadState st m)+    => MonadState st (ParsecT e s m) where   get = lift get   put = lift . put -instance MonadCont m => MonadCont (ParsecT s m) where+instance (ErrorComponent e, Stream s, MonadCont m)+    => MonadCont (ParsecT e s m) where   callCC f = mkPT $ \s ->     callCC $ \c ->       runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s     where pack s a = Reply s Virgin (OK a) -instance MonadError e m => MonadError e (ParsecT s m) where+instance (ErrorComponent e, Stream s, MonadError e' m)+    => MonadError e' (ParsecT e s m) where   throwError = lift . throwError   p `catchError` h = mkPT $ \s ->     runParsecT p s `catchError` \e ->       runParsecT (h e) s -instance MonadPlus (ParsecT s m) where+instance (ErrorComponent e, Stream s)+    => MonadPlus (ParsecT e s m) where   mzero = pZero   mplus = pPlus -pZero :: ParsecT s m a+pZero :: ParsecT e s m a pZero = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->-  eerr (newErrorUnknown pos) s+  eerr (ParseError pos E.empty E.empty E.empty) s+{-# INLINE pZero #-} -pPlus :: ParsecT s m a -> ParsecT s m a -> ParsecT s m a+pPlus :: (ErrorComponent e, Stream s)+  => ParsecT e s m a+  -> ParsecT e s m a+  -> ParsecT e s m a pPlus m n = ParsecT $ \s cok cerr eok eerr ->   let meerr err ms =         let ncerr err' s' = cerr (err' <> err) (longestMatch ms s')@@ -405,26 +467,42 @@   in unParser m s cok cerr eok meerr {-# INLINE pPlus #-} -instance MonadTrans (ParsecT s) where-  lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty+-- | From two states, return the one with greater textual position. If the+-- positions are equal, prefer the latter state. +longestMatch :: State s -> State s -> State s+longestMatch s1@(State _ pos1 _) s2@(State _ pos2 _) =+  case pos1 `compare` pos2 of+    LT -> s2+    EQ -> s2+    GT -> s1+{-# INLINE longestMatch #-}++instance MonadTrans (ParsecT e s) where+  lift amb = ParsecT $ \s _ _ eok _ ->+    amb >>= \a -> eok a s mempty+ ---------------------------------------------------------------------------- -- Primitive combinators  -- | Type class describing parsers independent of input type. -class (A.Alternative m, MonadPlus m, Stream s t)-  => MonadParsec s m t | m -> s t where+class (ErrorComponent e, Stream s, A.Alternative m, MonadPlus m)+    => MonadParsec e s m | m -> e s where    -- | The most general way to stop parsing and report 'ParseError'.   ---  -- 'unexpected' is defined in terms of the function:+  -- 'unexpected' is defined in terms of this function:   ---  -- > unexpected = failure . pure . Unexpected+  -- > unexpected item = failure (Set.singleton item) Set.empty Set.empty   --   -- @since 4.2.0 -  failure :: [Message] -> m a+  failure+    :: Set (ErrorItem (Token s)) -- ^ Unexpected items+    -> Set (ErrorItem (Token s)) -- ^ Expected items+    -> Set e                     -- ^ Custom data+    -> m a    -- | The parser @label name p@ behaves as parser @p@, but whenever the   -- parser @p@ fails /without consuming any input/, it replaces names of@@ -446,8 +524,8 @@   -- ('A.<|>') combinator will try its second alternative even when the   -- first parser failed while consuming input.   ---  -- For example, here is a parser that will /try/ (sorry for the pun) to-  -- parse word “let” or “lexical”:+  -- For example, here is a parser that is supposed to parse word “let” or+  -- “lexical”:   --   -- >>> parseTest (string "let" <|> string "lexical") "lexical"   -- 1:1:@@ -456,8 +534,8 @@   --   -- What happens here? First parser consumes “le” and fails (because it   -- doesn't see a “t”). The second parser, however, isn't tried, since the-  -- first parser has already consumed some input! @try@ fixes this-  -- behavior and allows backtracking to work:+  -- first parser has already consumed some input! @try@ fixes this behavior+  -- and allows backtracking to work:   --   -- >>> parseTest (try (string "let") <|> string "lexical") "lexical"   -- "lexical"@@ -490,11 +568,11 @@    notFollowedBy :: m a -> m () -  -- | @withRecovery r p@ allows continue parsing even if parser @p@-  -- fails. In this case @r@ is called with actual 'ParseError' as its-  -- argument. Typical usage is to return value signifying failure to parse-  -- this particular object and to consume some part of input up to start of-  -- next object.+  -- | @withRecovery r p@ allows continue parsing even if parser @p@ fails.+  -- In this case @r@ is called with actual 'ParseError' as its argument.+  -- Typical usage is to return value signifying failure to parse this+  -- particular object and to consume some part of input up to start of next+  -- object.   --   -- Note that if @r@ fails, original error message is reported as if   -- without 'withRecovery'. In no way recovering parser @r@ can influence@@ -503,7 +581,7 @@   -- @since 4.4.0    withRecovery-    :: (ParseError -> m a) -- ^ How to recover from failure+    :: (ParseError (Token s) e -> m a) -- ^ How to recover from failure     -> m a             -- ^ Original parser     -> m a             -- ^ Parser that can recover from failures @@ -511,37 +589,38 @@    eof :: m () -  -- | The parser @token nextPos testTok@ accepts a token @t@ with result-  -- @x@ when the function @testTok t@ returns @'Right' x@. The position of-  -- the /next/ token should be returned when @nextPos@ is called with the-  -- tab width, current source position, and the current token.+  -- | The parser @token test mrep@ accepts a token @t@ with result @x@ when+  -- the function @test t@ returns @'Right' x@. @mrep@ may provide+  -- representation of the token to report in error messages when input+  -- stream in empty.   --   -- This is the most primitive combinator for accepting tokens. For-  -- example, the 'Text.Megaparsec.Char.char' parser could be implemented-  -- as:+  -- example, the 'Text.Megaparsec.Char.satisfy' parser is implemented as:   ---  -- > char c = token updatePosChar testChar-  -- >   where testChar x = if x == c-  -- >                      then Right x-  -- >                      else Left . pure . Unexpected . showToken $ x+  -- > satisfy f = token testChar Nothing+  -- >   where+  -- >     testChar x =+  -- >       if f x+  -- >         then Right x+  -- >         else Left (Set.singleton (Tokens (x:|[])), Set.empty, Set.empty)    token-    :: (Int -> SourcePos -> t -> SourcePos)-       -- ^ Next position calculating function-    -> (t -> Either [Message] a)-       -- ^ Matching function for the token to parse+    :: (Token s -> Either ( Set (ErrorItem (Token s))+                          , Set (ErrorItem (Token s))+                          , Set e ) a)+       -- ^ Matching function for the token to parse, it allows to construct+       -- arbitrary error message on failure as well; sets in three-tuple+       -- are: unexpected items, expected items, and custom data pieces+    -> Maybe (Token s) -- ^ Token to report when input stream is empty     -> m a -  -- | The parser @tokens posFromTok test@ parses list of tokens and returns-  -- it. @posFromTok@ is called with three arguments: tab width, initial-  -- position, and collection of tokens to parse. The resulting parser will-  -- use 'showToken' to pretty-print the collection of tokens in error-  -- messages. Supplied predicate @test@ is used to check equality of given-  -- and parsed tokens.+  -- | The parser @tokens test@ parses list of tokens and returns it.+  -- Supplied predicate @test@ is used to check equality of given and parsed+  -- tokens.   --   -- This can be used for example to write 'Text.Megaparsec.Char.string':   ---  -- > string = tokens updatePosString (==)+  -- > string = tokens (==)   --   -- Note that beginning from Megaparsec 4.4.0, this is an auto-backtracking   -- primitive, which means that if it fails, it never consumes any@@ -556,17 +635,15 @@   --   -- This means, in particular, that it's no longer necessary to use 'try'   -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and-  -- 'Text.Megaparsec.Char.string''. This new feature /does not/ affect+  -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect   -- performance in any way. -  tokens :: Eq t-    => (Int -> SourcePos -> [t] -> SourcePos)-       -- ^ Computes position of tokens-    -> (t -> t -> Bool)+  tokens+    :: (Token s -> Token s -> Bool)        -- ^ Predicate to check equality of tokens-    -> [t]+    -> [Token s]        -- ^ List of tokens to parse-    -> m [t]+    -> m [Token s]    -- | Returns the full parser state as a 'State' record. @@ -576,7 +653,7 @@    updateParserState :: (State s -> State s) -> m () -instance Stream s t => MonadParsec s (ParsecT s m) t where+instance (ErrorComponent e, Stream s) => MonadParsec e s (ParsecT e s m) where   failure           = pFailure   label             = pLabel   try               = pTry@@ -589,42 +666,52 @@   getParserState    = pGetParserState   updateParserState = pUpdateParserState -pFailure :: [Message] -> ParsecT s m a-pFailure msgs = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->-  eerr (newErrorMessages msgs pos) s+pFailure+  :: Set (ErrorItem (Token s))+  -> Set (ErrorItem (Token s))+  -> Set e+  -> ParsecT e s m a+pFailure us ps xs = ParsecT $ \s@(State _ pos _) _ _ _ eerr ->+  eerr (ParseError pos us ps xs) s+{-# INLINE pFailure #-} -pLabel :: String -> ParsecT s m a -> ParsecT s m a+pLabel :: String -> ParsecT e s m a -> ParsecT e s m a pLabel l p = ParsecT $ \s cok cerr eok eerr ->-  let l' = if null l then l else "rest of " ++ l-      cok' x s' hs = cok x s' $ refreshLastHint hs l'-      eok' x s' hs = eok x s' $ refreshLastHint hs l-      eerr'    err = eerr $ setErrorMessage (Expected l) err+  let el = Label <$> NE.nonEmpty l+      cl = Label . (NE.fromList "rest of " <>) <$> NE.nonEmpty l+      cok' x s' hs = cok x s' (refreshLastHint hs cl)+      eok' x s' hs = eok x s' (refreshLastHint hs el)+      eerr'    err = eerr err+        { errorExpected = maybe E.empty E.singleton el }   in unParser p s cok' cerr eok' eerr'+{-# INLINE pLabel #-} -pTry :: ParsecT s m a -> ParsecT s m a+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 {-# INLINE pTry #-} -pLookAhead :: ParsecT s m a -> ParsecT s m a+pLookAhead :: ParsecT e s m a -> ParsecT e s m a pLookAhead p = ParsecT $ \s _ cerr eok eerr ->   let eok' a _ _ = eok a s mempty   in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} -pNotFollowedBy :: Stream s t => ParsecT s m a -> ParsecT s m ()+pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input pos _) _ _ eok eerr ->-  let l = maybe eoi (showToken . fst) (uncons input)-      cok' _ _ _ = eerr (unexpectedErr l pos) s+  let what = maybe EndOfInput (Tokens . nes . fst) (uncons input)+      unexpect u = ParseError pos (E.singleton u) E.empty E.empty+      cok' _ _ _ = eerr (unexpect what) s       cerr'  _ _ = eok () s mempty-      eok' _ _ _ = eerr (unexpectedErr l pos) s+      eok' _ _ _ = eerr (unexpect what) s       eerr'  _ _ = eok () s mempty   in unParser p s cok' cerr' eok' eerr'+{-# INLINE pNotFollowedBy #-} -pWithRecovery :: Stream s t-  => (ParseError -> ParsecT s m a)-  -> ParsecT s m a-  -> ParsecT s m a+pWithRecovery+  :: (ParseError (Token s) e -> ParsecT e s m a)+  -> ParsecT e s m a+  -> ParsecT e s m a pWithRecovery r p = ParsecT $ \s cok cerr eok eerr ->   let mcerr err ms =         let rcok x s' _ = cok x s' mempty@@ -641,57 +728,92 @@   in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} -pEof :: Stream s t => ParsecT s m ()-pEof = label eoi $ ParsecT $ \s@(State input pos _) _ _ eok eerr ->+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     Nothing    -> eok () s mempty-    Just (x,_) -> eerr (unexpectedErr (showToken x) pos) s+    Just (x,_) ->+      let !apos = fst (updatePos (Proxy :: Proxy s) w pos x)+      in eerr ParseError+          { errorPos        = apos:|z+          , errorUnexpected = (E.singleton . Tokens . nes) x+          , errorExpected   = E.singleton EndOfInput+          , errorCustom     = E.empty }+          (State input (apos:|z) w) {-# INLINE pEof #-} -pToken :: Stream s t-  => (Int -> SourcePos -> t -> SourcePos)-  -> (t -> Either [Message] a)-  -> ParsecT s m a-pToken nextpos test = ParsecT $ \s@(State input pos w) cok _ _ eerr ->-    case uncons input of-      Nothing     -> eerr (unexpectedErr eoi pos) s-      Just (c,cs) ->-        case test c of-          Left ms -> eerr (addErrorMessages ms (newErrorUnknown pos)) s-          Right x -> let newpos   = nextpos w pos c-                         newstate = State cs newpos w-                     in seq newpos $ seq newstate $ cok x newstate mempty+pToken :: forall e s m a. Stream s+  => (Token s -> Either ( Set (ErrorItem (Token s))+                        , Set (ErrorItem (Token s))+                        , Set e ) a)+  -> Maybe (Token s)+  -> ParsecT e s m a+pToken test mtoken = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr ->+  case uncons input of+    Nothing -> eerr ParseError+      { errorPos        = pos:|z+      , errorUnexpected = E.singleton EndOfInput+      , errorExpected   = maybe E.empty (E.singleton . Tokens . nes) mtoken+      , errorCustom     = E.empty } s+    Just (c,cs) ->+      let (apos, npos) = updatePos (Proxy :: Proxy s) w pos c+      in case test c of+        Left (us, ps, xs) ->+          apos `seq` eerr+            (ParseError (apos:|z) us ps xs)+            (State input (apos:|z) w)+        Right x ->+          let newstate = State cs (npos:|z) w+          in npos `seq` cok x newstate mempty {-# INLINE pToken #-} -pTokens :: Stream s t-  => (Int -> SourcePos -> [t] -> SourcePos)-  -> (t -> t -> Bool)-  -> [t]-  -> ParsecT s m [t]-pTokens _ _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty-pTokens nextpos test tts = ParsecT $ \s@(State input pos w) cok _ _ eerr ->-  let r = showToken . reverse-      errExpect x = setErrorMessage (Expected $ showToken tts)-        (newErrorMessage (Unexpected x) pos)-      walk [] is rs =-        let pos' = nextpos w pos tts-            s'   = State rs pos' w-        in cok (reverse is) s' mempty-      walk (t:ts) is rs =-        let what = if null is then eoi  else r is-        in case uncons rs of-             Nothing -> eerr (errExpect what) s-             Just (x,xs)-               | test t x  -> walk ts (x:is) xs-               | otherwise -> eerr (errExpect $ r (x:is)) s-  in walk tts [] input+pTokens :: forall e s m. Stream s+  => (Token s -> Token s -> Bool)+  -> [Token s]+  -> ParsecT e s m [Token s]+pTokens _ [] = ParsecT $ \s _ _ eok _ -> eok [] s mempty+pTokens test tts = ParsecT $ \s@(State input (pos:|z) w) cok _ _ eerr ->+  let updatePos' = updatePos (Proxy :: Proxy s) w+      toTokens   = Tokens . NE.fromList . reverse+      unexpect pos' u = ParseError+        { errorPos        = pos'+        , errorUnexpected = E.singleton u+        , errorExpected   = (E.singleton . Tokens . NE.fromList) tts+        , errorCustom     = E.empty }+      go _ [] is rs =+        let ris   = reverse is+            !npos = foldl' (\p t -> snd (updatePos' p t)) pos ris+        in cok ris (State rs (npos:|z) w) mempty+      go apos (t:ts) is rs =+        case uncons rs of+          Nothing ->+            apos `seq` eerr+              (unexpect (apos:|z) (toTokens is))+              (State input (apos:|z) w)+          Just (x,xs) ->+            if test t x+              then go apos ts (x:is) xs+              else apos `seq` eerr+                     (unexpect (apos:|z) . toTokens $ x:is)+                     (State input (apos:|z) w)+  in case uncons input of+       Nothing ->+         eerr (unexpect (pos:|z) EndOfInput) s+       Just (x,xs) ->+         let t:ts = tts+             apos = fst (updatePos' pos x)+         in if test t x+              then go apos ts [x] xs+              else apos `seq` eerr+                     (unexpect (apos:|z) $ Tokens (nes x))+                     (State input (apos:|z) w) {-# INLINE pTokens #-} -pGetParserState :: ParsecT s m (State s)+pGetParserState :: ParsecT e s m (State s) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} -pUpdateParserState :: (State s -> State s) -> ParsecT s m ()+pUpdateParserState :: (State s -> State s) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} @@ -699,65 +821,92 @@  infix 0 <?> -(<?>) :: MonadParsec s m t => m a -> String -> m a+(<?>) :: MonadParsec e s m => m a -> String -> m a (<?>) = flip label --- | The parser @unexpected msg@ always fails with an unexpected error--- message @msg@ without consuming any input.------ The parsers 'fail', 'label' and 'unexpected' are the three parsers used--- to generate error messages. Of these, only 'label' is commonly used.+-- | The parser @unexpected item@ always fails with an error message telling+-- about unexpected item @item@ without consuming any input. -unexpected :: MonadParsec s m t => String -> m a-unexpected = failure . pure . Unexpected+unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a+unexpected item = failure (E.singleton item) E.empty E.empty+{-# INLINE unexpected #-} -unexpectedErr :: String -> SourcePos -> ParseError-unexpectedErr msg = newErrorMessage (Unexpected msg)+-- | Make a singleton non-empty list from a value. -eoi :: String-eoi = "end of input"+nes :: a -> NonEmpty a+nes x = x :| []+{-# INLINE nes #-}  ---------------------------------------------------------------------------- -- Parser state combinators --- | Returns the current input.+-- | Return the current input. -getInput :: MonadParsec s m t => m s+getInput :: MonadParsec e s m => m s getInput = stateInput <$> getParserState  -- | @setInput input@ continues parsing with @input@. The 'getInput' and--- @setInput@ functions can for example be used to deal with #include files.+-- 'setInput' functions can for example be used to deal with include files. -setInput :: MonadParsec s m t => s -> m ()+setInput :: MonadParsec e s m => s -> m () setInput s = updateParserState (\(State _ pos w) -> State s pos w) --- | Returns the current source position.+-- | Return the current source position. ----- See also: 'SourcePos'.+-- See also: 'setPosition', 'pushPosition', 'popPosition', and 'SourcePos'. -getPosition :: MonadParsec s m t => m SourcePos-getPosition = statePos <$> getParserState+getPosition :: MonadParsec e s m => m SourcePos+getPosition = NE.head . statePos <$> getParserState  -- | @setPosition pos@ sets the current source position to @pos@.+--+-- See also: 'getPosition', 'pushPosition', 'popPosition', and 'SourcePos'. -setPosition :: MonadParsec s m t => SourcePos -> m ()-setPosition pos = updateParserState (\(State s _ w) -> State s pos w)+setPosition :: MonadParsec e s m => SourcePos -> m ()+setPosition pos = updateParserState $ \(State s (_:|z) w) ->+  State s (pos:|z) w --- | Returns tab width. Default tab width is equal to 'defaultTabWidth'. You+-- | Push given position into stack of positions and continue parsing+-- working with this position. Useful for working with include files and the+-- like.+--+-- See also: 'getPosition', 'setPosition', 'popPosition', and 'SourcePos'.+--+-- @since 5.0.0++pushPosition :: MonadParsec e s m => SourcePos -> m ()+pushPosition pos = updateParserState $ \(State s z w) ->+  State s (NE.cons pos z) w++-- | Pop a position from stack of positions unless it only contains one+-- element (in that case stack of positions remains the same). This is how+-- to return to previous source file after 'pushPosition'.+--+-- See also: 'getPosition', 'setPosition', 'pushPosition', and 'SourcePos'.+--+-- @since 5.0.0++popPosition :: MonadParsec e s m => m ()+popPosition = updateParserState $ \(State s z w) ->+  case snd (NE.uncons z) of+    Nothing -> State s z w+    Just z' -> State s z' w++-- | Return tab width. Default tab width is equal to 'defaultTabWidth'. You -- can set different tab width with help of 'setTabWidth'. -getTabWidth :: MonadParsec s m t => m Int+getTabWidth :: MonadParsec e s m => m Pos getTabWidth = stateTabWidth <$> getParserState  -- | Set tab width. If argument of the function is not positive number, -- 'defaultTabWidth' will be used. -setTabWidth :: MonadParsec s m t => Int -> m ()+setTabWidth :: MonadParsec e s m => Pos -> m () setTabWidth w = updateParserState (\(State s pos _) -> State s pos w)  -- | @setParserState st@ set the full parser state to @st@. -setParserState :: MonadParsec s m t => State s -> m ()+setParserState :: MonadParsec e s m => State s -> m () setParserState st = updateParserState (const st)  ----------------------------------------------------------------------------@@ -766,21 +915,21 @@ -- | @parse p file input@ runs parser @p@ over 'Identity' (see 'runParserT' -- if you're using the 'ParsecT' monad transformer; 'parse' itself is just a -- synonym for 'runParser'). It returns either a 'ParseError' ('Left') or a--- value of type @a@ ('Right'). 'show' or 'print' can be used to turn+-- value of type @a@ ('Right'). 'parseErrorPretty' can be used to turn -- 'ParseError' into the string representation of the error message. See -- "Text.Megaparsec.Error" if you need to do more advanced error analysis. ----- > main = case (parse numbers "" "11, 2, 43") of--- >          Left err -> print err+-- > main = case (parse numbers "" "11,2,43") of+-- >          Left err -> putStr (parseErrorPretty err) -- >          Right xs -> print (sum xs) -- >--- > numbers = commaSep integer+-- > numbers = integer `sepBy` char ',' -parse :: Stream s t-  => Parsec s a -- ^ Parser to run-  -> String     -- ^ Name of source file-  -> s          -- ^ Input for parser-  -> Either ParseError a+parse+  :: Parsec e s a -- ^ Parser to run+  -> String       -- ^ Name of source file+  -> s            -- ^ Input for parser+  -> Either (ParseError (Token s) e) a parse = runParser  -- | @parseMaybe p input@ runs parser @p@ on @input@ and returns result@@ -793,19 +942,25 @@ -- should be parsed. For example it can be used when parsing of single -- number according to specification of its format is desired. -parseMaybe :: Stream s t => Parsec s a -> s -> Maybe a+parseMaybe :: (ErrorComponent e, Stream s) => Parsec e s a -> s -> Maybe a parseMaybe p s =   case parse (p <* eof) "" s of     Left  _ -> Nothing     Right x -> Just x --- | The expression @parseTest p input@ applies a parser @p@ against--- input @input@ and prints the result to stdout. Used for testing.+-- | The expression @parseTest p input@ applies a parser @p@ against input+-- @input@ and prints the result to stdout. Useful for testing. -parseTest :: (Stream s t, Show a) => Parsec s a -> s -> IO ()+parseTest :: ( ShowErrorComponent e+             , Ord (Token s)+             , ShowToken (Token s)+             , Show a )+  => Parsec e s a -- ^ Parser to run+  -> s            -- ^ Input for parser+  -> IO () parseTest p input =   case parse p "" input of-    Left  e -> print e+    Left  e -> putStr (parseErrorPretty e)     Right x -> print x  -- | @runParser p file input@ runs parser @p@ on the input list of tokens@@ -815,11 +970,11 @@ -- -- > parseFromFile p file = runParser p file <$> readFile file -runParser :: Stream s t-  => Parsec s a -- ^ Parser to run+runParser+  :: Parsec e s a -- ^ Parser to run   -> String     -- ^ Name of source file   -> s          -- ^ Input for parser-  -> Either ParseError a+  -> Either (ParseError (Token s) e) a runParser p name s = snd $ runParser' p (initialState name s)  -- | The function is similar to 'runParser' with the difference that it@@ -829,10 +984,10 @@ -- -- @since 4.2.0 -runParser' :: Stream s t-  => Parsec s a -- ^ Parser to run+runParser'+  :: Parsec e s a -- ^ Parser to run   -> State s    -- ^ Initial state-  -> (State s, Either ParseError a)+  -> (State s, Either (ParseError (Token s) e) a) runParser' p = runIdentity . runParserT' p  -- | @runParserT p file input@ runs parser @p@ on the input list of tokens@@ -841,11 +996,11 @@ -- underlying monad @m@ that returns either a 'ParseError' ('Left') or a -- value of type @a@ ('Right'). -runParserT :: (Monad m, Stream s t)-  => ParsecT s m a -- ^ Parser to run+runParserT :: Monad m+  => ParsecT e s m a -- ^ Parser to run   -> String        -- ^ Name of source file   -> s             -- ^ Input for parser-  -> m (Either ParseError a)+  -> m (Either (ParseError (Token s) e) a) runParserT p name s = snd `liftM` runParserT' p (initialState name s)  -- | This function is similar to 'runParserT', but like 'runParser'' it@@ -854,10 +1009,10 @@ -- -- @since 4.2.0 -runParserT' :: (Monad m, Stream s t)-  => ParsecT s m a -- ^ Parser to run+runParserT' :: Monad m+  => ParsecT e s m a -- ^ Parser to run   -> State s       -- ^ Initial state-  -> m (State s, Either ParseError a)+  -> m (State s, Either (ParseError (Token s) e) a) runParserT' p s = do   (Reply s' _ result) <- runParsecT p s   case result of@@ -866,43 +1021,27 @@  -- | Given name of source file and input construct initial state for parser. -initialState :: Stream s t => String -> s -> State s-initialState name s = State s (initialPos name) defaultTabWidth+initialState :: String -> s -> State s+initialState name s = State s (initialPos name :| []) defaultTabWidth  -- | Low-level unpacking of the 'ParsecT' type. 'runParserT' and 'runParser' -- are built upon this.  runParsecT :: Monad m-  => ParsecT s m a -- ^ Parser to run+  => ParsecT e s m a -- ^ Parser to run   -> State s       -- ^ Initial state-  -> m (Reply s a)+  -> m (Reply e s a) runParsecT p s = unParser p s cok cerr eok eerr   where cok a s' _  = return $ Reply s' Consumed (OK a)         cerr err s' = return $ Reply s' Consumed (Error err)         eok a s' _  = return $ Reply s' Virgin   (OK a)         eerr err s' = return $ Reply s' Virgin   (Error err) --- | @parseFromFile p filename@ runs parser @p@ on the input read from--- @filename@. Returns either a 'ParseError' ('Left') or a value of type @a@--- ('Right').------ > main = do--- >   result <- parseFromFile numbers "digits.txt"--- >   case result of--- >     Left err -> print err--- >     Right xs -> print $ sum xs--parseFromFile :: StorableStream s t-  => Parsec s a -- ^ Parser to run-  -> FilePath   -- ^ Name of file to parse-  -> IO (Either ParseError a)-parseFromFile p filename = runParser p filename <$> fromFile filename- ---------------------------------------------------------------------------- -- Instances of 'MonadParsec' -instance MonadParsec s m t => MonadParsec s (L.StateT e m) t where-  failure                    = lift . failure+instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where+  failure us ps xs           = lift (failure us ps xs)   label n       (L.StateT m) = L.StateT $ label n . m   try           (L.StateT m) = L.StateT $ try . m   lookAhead     (L.StateT m) = L.StateT $ \s ->@@ -912,13 +1051,13 @@   withRecovery r (L.StateT m) = L.StateT $ \s ->     withRecovery (\e -> L.runStateT (r e) s) (m s)   eof                        = lift eof-  token  f e                 = lift $ token  f e-  tokens f e ts              = lift $ tokens f e ts+  token test mt              = lift (token test mt)+  tokens e ts                = lift (tokens e ts)   getParserState             = lift getParserState-  updateParserState f        = lift $ updateParserState f+  updateParserState f        = lift (updateParserState f) -instance MonadParsec s m t => MonadParsec s (S.StateT e m) t where-  failure                    = lift . failure+instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where+  failure us ps xs           = lift (failure us ps xs)   label n       (S.StateT m) = S.StateT $ label n . m   try           (S.StateT m) = S.StateT $ try . m   lookAhead     (S.StateT m) = S.StateT $ \s ->@@ -928,13 +1067,13 @@   withRecovery r (S.StateT m) = S.StateT $ \s ->     withRecovery (\e -> S.runStateT (r e) s) (m s)   eof                        = lift eof-  token  f e                 = lift $ token  f e-  tokens f e ts              = lift $ tokens f e ts+  token test mt              = lift (token test mt)+  tokens e ts                = lift (tokens e ts)   getParserState             = lift getParserState-  updateParserState f        = lift $ updateParserState f+  updateParserState f        = lift (updateParserState f) -instance MonadParsec s m t => MonadParsec s (L.ReaderT e m) t where-  failure                     = lift . failure+instance MonadParsec e s m => MonadParsec e s (L.ReaderT st m) where+  failure us ps xs            = lift (failure us ps xs)   label n       (L.ReaderT m) = L.ReaderT $ label n . m   try           (L.ReaderT m) = L.ReaderT $ try . m   lookAhead     (L.ReaderT m) = L.ReaderT $ lookAhead . m@@ -942,13 +1081,13 @@   withRecovery r (L.ReaderT m) = L.ReaderT $ \s ->     withRecovery (\e -> L.runReaderT (r e) s) (m s)   eof                         = lift eof-  token  f e                  = lift $ token  f e-  tokens f e ts               = lift $ tokens f e ts+  token test mt               = lift (token test mt)+  tokens e ts                 = lift (tokens e ts)   getParserState              = lift getParserState-  updateParserState f         = lift $ updateParserState f+  updateParserState f         = lift (updateParserState f) -instance (Monoid w, MonadParsec s m t) => MonadParsec s (L.WriterT w m) t where-  failure                     = lift . failure+instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where+  failure us ps xs            = lift (failure us ps xs)   label n       (L.WriterT m) = L.WriterT $ label n m   try           (L.WriterT m) = L.WriterT $ try m   lookAhead     (L.WriterT m) = L.WriterT $@@ -958,13 +1097,13 @@   withRecovery r (L.WriterT m) = L.WriterT $     withRecovery (L.runWriterT . r) m   eof                         = lift eof-  token  f e                  = lift $ token  f e-  tokens f e ts               = lift $ tokens f e ts+  token test mt               = lift (token test mt)+  tokens e ts                 = lift (tokens e ts)   getParserState              = lift getParserState-  updateParserState f         = lift $ updateParserState f+  updateParserState f         = lift (updateParserState f) -instance (Monoid w, MonadParsec s m t) => MonadParsec s (S.WriterT w m) t where-  failure                     = lift . failure+instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where+  failure us ps xs            = lift (failure us ps xs)   label n       (S.WriterT m) = S.WriterT $ label n m   try           (S.WriterT m) = S.WriterT $ try m   lookAhead     (S.WriterT m) = S.WriterT $@@ -974,13 +1113,13 @@   withRecovery r (S.WriterT m) = S.WriterT $     withRecovery (S.runWriterT . r) m   eof                         = lift eof-  token  f e                  = lift $ token  f e-  tokens f e ts               = lift $ tokens f e ts+  token test mt               = lift (token test mt)+  tokens e ts                 = lift (tokens e ts)   getParserState              = lift getParserState-  updateParserState f         = lift $ updateParserState f+  updateParserState f         = lift (updateParserState f) -instance MonadParsec s m t => MonadParsec s (IdentityT m) t where-  failure                     = lift . failure+instance MonadParsec e s m => MonadParsec e s (IdentityT m) where+  failure us ps xs            = lift (failure us ps xs)   label n       (IdentityT m) = IdentityT $ label n m   try                         = IdentityT . try . runIdentityT   lookAhead     (IdentityT m) = IdentityT $ lookAhead m@@ -988,7 +1127,7 @@   withRecovery r (IdentityT m) = IdentityT $     withRecovery (runIdentityT . r) m   eof                         = lift eof-  token  f e                  = lift $ token  f e-  tokens f e ts               = lift $ tokens f e ts+  token test mt               = lift (token test mt)+  tokens e ts                 = lift $ tokens e ts   getParserState              = lift getParserState   updateParserState f         = lift $ updateParserState f

@@ -1,53 +0,0 @@--- |--- Module      :  Text.Megaparsec.ShowToken--- Copyright   :  © 2015–2016 Megaparsec contributors--- License     :  FreeBSD------ Maintainer  :  Mark Karpov <markkarpov@opmbx.org>--- Stability   :  experimental--- Portability :  portable------ Pretty printing function and instances for use in error messages.--module Text.Megaparsec.ShowToken (ShowToken (..)) where---- | Typeclass 'ShowToken' defines single function 'showToken' that can be--- used to “pretty-print” various tokens. By default, all commonly used--- instances are defined, but you can add your own, of course.--class Show a => ShowToken a where--  -- | Pretty-print given token. This is used to get token representation-  -- for use in error messages.--  showToken :: a -> String--instance ShowToken Char where-  showToken = prettyChar---- | @prettyChar ch@ returns user-friendly string representation of given--- character @ch@, suitable for using in error messages, for example.--prettyChar :: Char -> String-prettyChar '\0' = "null"-prettyChar '\a' = "bell"-prettyChar '\b' = "backspace"-prettyChar '\t' = "tab"-prettyChar '\n' = "newline"-prettyChar '\v' = "vertical tab"-prettyChar '\f' = "form feed"-prettyChar '\r' = "carriage return"-prettyChar ' '  = "space"-prettyChar x    = "'" ++ [x] ++ "'"--instance ShowToken String where-  showToken = prettyString---- | @prettyString s@ returns pretty representation of string @s@. This is--- used when printing string tokens in error messages.--prettyString :: String -> String-prettyString ""     = ""-prettyString [x]    = prettyChar x-prettyString "\r\n" = "crlf newline"-prettyString xs     = "\"" ++ xs ++ "\""

@@ -1,22 +1,21 @@ -- | -- Module      :  Text.Megaparsec.String -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2007 Paolo Martini -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Make Strings an instance of 'Stream' with 'Char' token type.+-- Convenience definitions for working with 'String' as input stream.  module Text.Megaparsec.String (Parser) where +import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim --- | Different modules corresponding to various types of streams (@String@,--- @Text@, @ByteString@) define it differently, so user can use “abstract”--- @Parser@ type and easily change it by importing different “type--- modules”. This one is for strings.+-- | Modules corresponding to various types of streams define 'Parser'+-- accordingly, so user can use it to easily change type of input stream by+-- importing different “type modules”. This one is for strings. -type Parser = Parsec String+type Parser = Parsec Dec String

@@ -1,23 +1,22 @@ -- | -- Module      :  Text.Megaparsec.Text -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2011 Antoine Latter -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Convenience definitions for working with 'T.Text'.+-- Convenience definitions for working with strict 'Text'.  module Text.Megaparsec.Text (Parser) where +import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim-import qualified Data.Text as T+import Data.Text --- | Different modules corresponding to various types of streams (@String@,--- @Text@, @ByteString@) define it differently, so user can use “abstract”--- @Parser@ type and easily change it by importing different “type--- modules”. This one is for strict text.+-- | Modules corresponding to various types of streams define 'Parser'+-- accordingly, so user can use it to easily change type of input stream by+-- importing different “type modules”. This one is for strict text. -type Parser = Parsec T.Text+type Parser = Parsec Dec Text

@@ -1,23 +1,22 @@ -- | -- Module      :  Text.Megaparsec.Text.Lazy -- Copyright   :  © 2015–2016 Megaparsec contributors---                © 2011 Antoine Latter -- License     :  FreeBSD -- -- Maintainer  :  Mark Karpov <markkarpov@opmbx.org> -- Stability   :  experimental -- Portability :  portable ----- Convenience definitions for working with lazy 'T.Text'.+-- Convenience definitions for working with lazy 'Text'.  module Text.Megaparsec.Text.Lazy (Parser) where +import Data.Text.Lazy+import Text.Megaparsec.Error (Dec) import Text.Megaparsec.Prim-import qualified Data.Text.Lazy as T --- | Different modules corresponding to various types of streams (@String@,--- @Text@, @ByteString@) define it differently, so user can use “abstract”--- @Parser@ type and easily change it by importing different “type--- modules”. This one is for lazy text.+-- | Modules corresponding to various types of streams define 'Parser'+-- accordingly, so user can use it to easily change type of input stream by+-- importing different “type modules”. This one is for lazy text. -type Parser = Parsec T.Text+type Parser = Parsec Dec Text

@@ -27,7 +27,7 @@ -- POSSIBILITY OF SUCH DAMAGE.  name:                 megaparsec-version:              4.4.0+version:              5.0.0 cabal-version:        >= 1.10 license:              BSD2 license-file:         LICENSE.md@@ -58,7 +58,10 @@ library   build-depends:      base         >= 4.6 && < 5                     , bytestring+                    , containers   >= 0.5 && < 0.6+                    , exceptions   >= 0.6 && < 0.9                     , mtl          == 2.*+                    , scientific   >= 0.3.1 && < 0.4                     , text         >= 0.2                     , transformers >= 0.4 && < 0.6 @@ -67,16 +70,9 @@     build-depends:    fail         == 4.9.*                     , semigroups   == 0.18.* -  default-extensions: CPP-                    , DeriveDataTypeable-                    , FlexibleContexts-                    , FlexibleInstances-                    , FunctionalDependencies-                    , GeneralizedNewtypeDeriving-                    , MultiParamTypeClasses-                    , PolymorphicComponents-                    , TupleSections-                    , UndecidableInstances+  if !impl(ghc >= 7.8)+    build-depends:    tagged       == 0.8.*+   exposed-modules:    Text.Megaparsec                     , Text.Megaparsec.ByteString                     , Text.Megaparsec.ByteString.Lazy@@ -88,12 +84,11 @@                     , Text.Megaparsec.Perm                     , Text.Megaparsec.Pos                     , Text.Megaparsec.Prim-                    , Text.Megaparsec.ShowToken                     , Text.Megaparsec.String                     , Text.Megaparsec.Text                     , Text.Megaparsec.Text.Lazy   if flag(dev)-    ghc-options:      -Wall -Werror+    ghc-options:      -Wall     if impl(ghc >= 8.0)       ghc-options:    -Wcompat       ghc-options:    -Wnoncanonical-monadfail-instances@@ -107,7 +102,7 @@   hs-source-dirs:     old-tests   type:               exitcode-stdio-1.0   if flag(dev)-    ghc-options:      -Wall -Werror+    ghc-options:      -Wall   else     ghc-options:      -O2 -Wall   other-modules:      Bugs@@ -119,11 +114,9 @@                     , Util   build-depends:      base                 >= 4.6 && < 5                     , HUnit                >= 1.2 && < 1.4-                    , megaparsec           >= 4.4.0+                    , megaparsec           >= 5.0.0                     , test-framework       >= 0.6 && < 1                     , test-framework-hunit >= 0.2 && < 0.4-  default-extensions: CPP-                    , FlexibleContexts   default-language:   Haskell2010  test-suite tests@@ -131,7 +124,7 @@   hs-source-dirs:     tests   type:               exitcode-stdio-1.0   if flag(dev)-    ghc-options:      -Wall -Werror+    ghc-options:      -Wall   else     ghc-options:      -O2 -Wall   other-modules:      Char@@ -145,16 +138,26 @@                     , Util   build-depends:      base           >= 4.6 && < 5                     , HUnit          >= 1.2 && < 1.4-                    , QuickCheck     >= 2.4 && < 3-                    , megaparsec     >= 4.4.0+                    , QuickCheck     >= 2.8.2 && < 3+                    , bytestring+                    , containers     >= 0.5 && < 0.6+                    , exceptions     >= 0.6 && < 0.9+                    , megaparsec     >= 5.0.0                     , mtl            == 2.*+                    , scientific     >= 0.3.1 && < 0.4                     , test-framework >= 0.6 && < 1                     , test-framework-hunit       >= 0.3 && < 0.4                     , test-framework-quickcheck2 >= 0.3 && < 0.4+                    , text           >= 0.2                     , transformers   >= 0.4 && < 0.6-  default-extensions: CPP-                    , FlexibleContexts-                    , FlexibleInstances++  if !impl(ghc >= 8.0)+    -- packages providing modules that moved into base-4.9.0.0+    build-depends:    semigroups     == 0.18.*++  if !impl(ghc >= 7.8)+    build-depends:    tagged       == 0.8.*+   default-language:   Haskell2010  benchmark benchmarks@@ -162,13 +165,13 @@   hs-source-dirs:     benchmarks   type:               exitcode-stdio-1.0   if flag(dev)-    ghc-options:      -O2 -Wall -Werror+    ghc-options:      -O2 -Wall   else     ghc-options:      -O2 -Wall   build-depends:      base       >= 4.6 && < 5                     , bytestring >= 0.10 && < 2                     , criterion  >= 0.6.2.1 && < 1.2-                    , megaparsec >= 4.4.0+                    , megaparsec >= 5.0.0                     , text       >= 0.2   default-language:   Haskell2010 

@@ -1,4 +1,3 @@- module Bugs (bugs) where  import Test.Framework

@@ -1,4 +1,3 @@- module Bugs.Bug2 (main) where  import Control.Applicative (empty)

@@ -1,7 +1,7 @@- module Bugs.Bug35 (main) where  import Text.Megaparsec+import Text.Megaparsec.String import qualified Text.Megaparsec.Lexer as L  import Test.Framework@@ -28,7 +28,8 @@  testBatch :: Assertion testBatch = mapM_ testFloat trickyFloats-    where testFloat x = parse L.float "" x @?= Right (read x :: Double)+  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,3 +1,4 @@+{-# LANGUAGE CPP #-}  module Bugs.Bug39 (main) where 

@@ -1,4 +1,3 @@- module Bugs.Bug6 (main) where  import Text.Megaparsec@@ -17,7 +16,7 @@  variable :: Parser String variable = do-      x <- lookAhead (some letterChar)-      if x == "return"-      then fail "'return' is a reserved keyword"-      else string x+  x <- lookAhead (some letterChar)+  if x == "return"+    then fail "'return' is a reserved keyword"+    else string x

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+ module Bugs.Bug9 (main) where  import Control.Applicative (empty)

@@ -1,4 +1,3 @@- import Test.Framework  import Bugs (bugs)

@@ -1,4 +1,3 @@- module Util where  import Text.Megaparsec@@ -9,5 +8,5 @@ parseErrors :: Parser a -> String -> [String] parseErrors p input =   case parse p "" input of-    Left err -> drop 1 $ lines $ show err+    Left err -> drop 1 $ lines $ parseErrorPretty err     Right _  -> []

@@ -26,18 +26,22 @@ -- 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 @@ -82,59 +86,29 @@   , testProperty "string' (case)"  prop_string'_1 ]  instance Arbitrary GeneralCategory where-  arbitrary = elements-              [ UppercaseLetter-              , LowercaseLetter-              , TitlecaseLetter-              , ModifierLetter-              , OtherLetter-              , NonSpacingMark-              , SpacingCombiningMark-              , EnclosingMark-              , DecimalNumber-              , LetterNumber-              , OtherNumber-              , ConnectorPunctuation-              , DashPunctuation-              , OpenPunctuation-              , ClosePunctuation-              , InitialQuote-              , FinalQuote-              , OtherPunctuation-              , MathSymbol-              , CurrencySymbol-              , ModifierSymbol-              , OtherSymbol-              , Space-              , LineSeparator-              , ParagraphSeparator-              , Control-              , Format-              , Surrogate-              , PrivateUse-              , NotAssigned ]+  arbitrary = elements [minBound..maxBound]  prop_newline :: String -> Property-prop_newline = checkChar newline (== '\n') (Just "newline")+prop_newline = checkChar newline (== '\n') (tkn '\n')  prop_crlf :: String -> Property-prop_crlf = checkString crlf "\r\n" (==) "crlf newline"+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 [uneEof, exSpec "end of line"]-          | h == '\n'   = posErr 1 s [uneCh (s !! 1), exEof]-          | h /= '\r'   = posErr 0 s [uneCh h, exSpec "end of line"]-          | "\r\n" `isPrefixOf` s = posErr 2 s [uneCh (s !! 2), exEof]-          | otherwise   = posErr 0 s [ uneStr (take 2 s)-                                     , uneCh '\r'-                                     , exSpec "end of line" ]+          | 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') (Just "tab")+prop_tab = checkChar tab (== '\t') (tkn '\t')  prop_space :: String -> Property prop_space s = checkParser space r s@@ -142,71 +116,70 @@               Just x  ->                   let ch = s !! x                   in posErr x s-                     [ uneCh ch-                     , uneCh ch-                     , exSpec "white space"-                     , exEof ]+                     [ utok ch+                     , utok ch+                     , elabel "white space"+                     , eeof ]               Nothing -> Right ()  prop_controlChar :: String -> Property-prop_controlChar = checkChar controlChar isControl (Just "control character")+prop_controlChar = checkChar controlChar isControl (lbl "control character")  prop_spaceChar :: String -> Property-prop_spaceChar = checkChar spaceChar isSpace (Just "white space")+prop_spaceChar = checkChar spaceChar isSpace (lbl "white space")  prop_upperChar :: String -> Property-prop_upperChar = checkChar upperChar isUpper (Just "uppercase letter")+prop_upperChar = checkChar upperChar isUpper (lbl "uppercase letter")  prop_lowerChar :: String -> Property-prop_lowerChar = checkChar lowerChar isLower (Just "lowercase letter")+prop_lowerChar = checkChar lowerChar isLower (lbl "lowercase letter")  prop_letterChar :: String -> Property-prop_letterChar = checkChar letterChar isAlpha (Just "letter")+prop_letterChar = checkChar letterChar isAlpha (lbl "letter")  prop_alphaNumChar :: String -> Property-prop_alphaNumChar =-  checkChar alphaNumChar isAlphaNum (Just "alphanumeric character")+prop_alphaNumChar = checkChar alphaNumChar isAlphaNum+  (lbl "alphanumeric character")  prop_printChar :: String -> Property-prop_printChar = checkChar printChar isPrint (Just "printable character")+prop_printChar = checkChar printChar isPrint (lbl "printable character")  prop_digitChar :: String -> Property-prop_digitChar = checkChar digitChar isDigit (Just "digit")+prop_digitChar = checkChar digitChar isDigit (lbl "digit")  prop_octDigitChar :: String -> Property-prop_octDigitChar = checkChar octDigitChar isOctDigit (Just "octal digit")+prop_octDigitChar = checkChar octDigitChar isOctDigit (lbl "octal digit")  prop_hexDigitChar :: String -> Property-prop_hexDigitChar = checkChar hexDigitChar isHexDigit (Just "hexadecimal digit")+prop_hexDigitChar = checkChar hexDigitChar isHexDigit (lbl "hexadecimal digit")  prop_markChar :: String -> Property-prop_markChar = checkChar markChar isMark (Just "mark character")+prop_markChar = checkChar markChar isMark (lbl "mark character")  prop_numberChar :: String -> Property-prop_numberChar = checkChar numberChar isNumber (Just "numeric character")+prop_numberChar = checkChar numberChar isNumber (lbl "numeric character")  prop_punctuationChar :: String -> Property-prop_punctuationChar =-  checkChar punctuationChar isPunctuation (Just "punctuation")+prop_punctuationChar = checkChar punctuationChar isPunctuation (lbl "punctuation")  prop_symbolChar :: String -> Property-prop_symbolChar = checkChar symbolChar isSymbol (Just "symbol")+prop_symbolChar = checkChar symbolChar isSymbol (lbl "symbol")  prop_separatorChar :: String -> Property-prop_separatorChar = checkChar separatorChar isSeparator (Just "separator")+prop_separatorChar = checkChar separatorChar isSeparator (lbl "separator")  prop_asciiChar :: String -> Property-prop_asciiChar = checkChar asciiChar isAscii (Just "ASCII character")+prop_asciiChar = checkChar asciiChar isAscii (lbl "ASCII character")  prop_latin1Char :: String -> Property-prop_latin1Char = checkChar latin1Char isLatin1 (Just "Latin-1 character")+prop_latin1Char = checkChar latin1Char isLatin1 (lbl "Latin-1 character")  prop_charCategory :: GeneralCategory -> String -> Property-prop_charCategory cat = checkChar (charCategory cat) p (Just $ categoryName cat)+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) (Just $ showToken c)+prop_char c = checkChar (char c) (== c) (tkn c)  prop_char' :: Char -> String -> Property prop_char' c s = checkParser (char' c) r s@@ -214,13 +187,13 @@         l | isLower c = [c, toUpper c]           | isUpper c = [c, toLower c]           | otherwise = [c]-        r | null s         = posErr 0 s $ uneEof : (exCh <$> l)+        r | null s         = posErr 0 s $ ueof : (etok <$> l)           | length s == 1 && (h `elemi` l) = Right h-          | h `notElemi` l = posErr 0 s $ uneCh h : (exCh <$> l)-          | otherwise      = posErr 1 s [uneCh (s !! 1), exEof]+          | 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) (Just "character")+prop_anyChar = checkChar anyChar (const True) (lbl "character")  prop_oneOf :: String -> String -> Property prop_oneOf a = checkChar (oneOf a) (`elem` a) Nothing@@ -235,10 +208,10 @@ prop_noneOf' a = checkChar (noneOf' a) (`notElemi` a) Nothing  prop_string :: String -> String -> Property-prop_string a = checkString (string a) a (==) (showToken a)+prop_string a = checkString (string a) a (==)  prop_string'_0 :: String -> String -> Property-prop_string'_0 a = checkString (string' a) a casei (showToken a)+prop_string'_0 a = checkString (string' a) a casei  -- | Randomly change the case in the given string. @@ -249,7 +222,7 @@  prop_string'_1 :: String -> Property prop_string'_1 a = forAll (fuzzyCase a) $ \s ->-  checkString (string' a) a casei (showToken a) s+  checkString (string' a) a casei s  -- | Case-insensitive equality test for characters. @@ -265,3 +238,9 @@  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

@@ -66,10 +66,10 @@   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 $ exStr post :-                    if length post == b-                    then [uneEof, exCh c]-                    else [uneCh (post !! b), exCh c]+        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@@ -79,7 +79,7 @@   where cs = getNonEmpty cs'         p = choice $ char <$> cs         r | s' `elem` cs = Right s'-          | otherwise    = posErr 0 s $ uneCh s' : (exCh <$> cs)+          | otherwise    = posErr 0 s $ utok s' : (etok <$> cs)         s = [s']  prop_count :: Int -> NonNegative Int -> Property@@ -95,11 +95,11 @@         p = count' m n (char 'x')         r | n <= 0 || m > n  =               if x == 0-              then Right ""-              else posErr 0 s [uneCh 'x', exEof]+                then Right ""+                else posErr 0 s [utok 'x', eeof]           | m <= x && x <= n = Right s-          | x < m            = posErr x s [uneEof, exCh 'x']-          | otherwise        = posErr n s [uneCh 'x', exEof]+          | x < m            = posErr x s [ueof, etok 'x']+          | otherwise        = posErr n s [utok 'x', eeof]         s = replicate x 'x'  prop_eitherP :: Char -> Property@@ -107,19 +107,19 @@   where p = eitherP letterChar digitChar         r | isLetter ch = Right (Left  ch)           | isDigit  ch = Right (Right ch)-          | otherwise   = posErr 0 s [uneCh ch, exSpec "letter", exSpec "digit"]+          | 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 [uneEof, exCh '-']-          | c == 'a'           = posErr (g n) s [uneCh 'a', exCh '-']-          | c == '-' && n == 0 = posErr 0 s [uneCh '-', exCh 'a', exEof]-          | c /= '-'           = posErr (g n) s $ uneCh c :-                                 (if n > 0 then exCh '-' else exEof) :-                                 [exCh 'a' | n == 0]+        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] @@ -127,12 +127,11 @@ 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 [uneEof, exCh '-']-          | c == 'a'           = posErr (g n) s [uneCh 'a', exCh '-']-          | c == '-' && n == 0 = posErr 0 s [uneCh '-', exCh 'a']-          | c /= '-'           = posErr (g n) s $ uneCh c :-                                 [exCh '-' | n > 0] ++-                                 [exCh 'a' | n == 0]+        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] @@ -141,7 +140,7 @@ 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 [uneEof, exCh 'c', exSpec "letter"]+        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@@ -151,9 +150,9 @@ 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 [uneEof, exSpec "letter"]-          | c == 0    = posErr (a + b) s [uneEof, exCh 'c', exSpec "letter"]-          | s == "c"  = posErr 1 s [uneEof, exCh 'c', exSpec "letter"]+        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)@@ -171,9 +170,9 @@         p = sepBy (char 'a') (char '-')         r | isNothing c' = Right (replicate n 'a')           | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [uneCh c, exCh 'a', exEof]-          | c == '-'  = posErr (length s) s [uneEof, exCh 'a']-          | otherwise = posErr (g n) s [uneCh c, exCh '-', exEof]+          | 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@@ -182,11 +181,11 @@         c = fromJust c'         p = sepBy1 (char 'a') (char '-')         r | isNothing c' && n >= 1 = Right (replicate n 'a')-          | isNothing c' = posErr 0 s [uneEof, exCh 'a']+          | isNothing c' = posErr 0 s [ueof, etok 'a']           | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [uneCh c, exCh 'a']-          | c == '-'  = posErr (length s) s [uneEof, exCh 'a']-          | otherwise = posErr (g n) s [uneCh c, exCh '-', exEof]+          | 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@@ -197,9 +196,9 @@         a = Right $ replicate n 'a'         r | isNothing c' = a           | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [uneCh c, exCh 'a', exEof]+          | n == 0    = posErr 0 s [utok c, etok 'a', eeof]           | c == '-'  = a-          | otherwise = posErr (g n) s [uneCh c, exCh '-', exEof]+          | otherwise = posErr (g n) s [utok c, etok '-', eeof]         s = intersperse '-' (replicate n 'a') ++ maybeToList c'  prop_sepEndBy1 :: NonNegative Int -> Maybe Char -> Property@@ -209,11 +208,11 @@         p = sepEndBy1 (char 'a') (char '-')         a = Right $ replicate n 'a'         r | isNothing c' && n >= 1 = a-          | isNothing c' = posErr 0 s [uneEof, exCh 'a']+          | isNothing c' = posErr 0 s [ueof, etok 'a']           | c == 'a' && n == 0 = Right "a"-          | n == 0    = posErr 0 s [uneCh c, exCh 'a']+          | n == 0    = posErr 0 s [utok c, etok 'a']           | c == '-'  = a-          | otherwise = posErr (g n) s [uneCh c, exCh '-', exEof]+          | otherwise = posErr (g n) s [utok c, etok '-', eeof]         s = intersperse '-' (replicate n 'a') ++ maybeToList c'  prop_skipMany :: Char -> NonNegative Int -> String -> Property

@@ -26,130 +26,127 @@ -- 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.Foldable (find)-import Data.List (isPrefixOf, isInfixOf)-import Data.Maybe (fromJust)+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 Pos () import Text.Megaparsec.Error import Text.Megaparsec.Pos +import Util ()+ #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*>))+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 "extraction of message string"    prop_messageString-  , testProperty "creation of new error messages"  prop_newErrorMessage-  , testProperty "messages are always well-formed" prop_wellFormedMessages-  , testProperty "copying of error positions"      prop_parseErrorCopy-  , testProperty "setting of error position"       prop_setErrorPos-  , testProperty "addition of error message"       prop_addErrorMessage-  , testProperty "setting of error message"        prop_setErrorMessage-  , testProperty "position of merged error"        prop_mergeErrorPos-  , testProperty "messages of merged error"        prop_mergeErrorMsgs-  , testProperty "position of error is visible"    prop_visiblePos-  , testProperty "message components are visible"  prop_visibleMsgs ]--instance Arbitrary Message where-  arbitrary = ($) <$> elements constructors <*> arbitrary-    where constructors = [Unexpected, Expected, Message]+  [ 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 ] -instance Arbitrary ParseError where-  arbitrary = do-    ms  <- listOf arbitrary-    err <- oneof [ newErrorUnknown <$> arbitrary-                 , newErrorMessage <$> arbitrary <*> arbitrary ]-    return $ addErrorMessages ms err+type PE = ParseError Char Dec -prop_monoid_left_id :: ParseError -> Bool-prop_monoid_left_id x = mempty <> x == x+prop_monoid_left_id :: PE -> Property+prop_monoid_left_id x = mempty <> x === x .&&.+  mempty { errorPos = errorPos x } <> x === x -prop_monoid_right_id :: ParseError -> Bool-prop_monoid_right_id x = x <> mempty == x+prop_monoid_right_id :: PE -> Property+prop_monoid_right_id x = x <> mempty === x .&&.+  mempty { errorPos = errorPos x } <> x === x -prop_monoid_assoc :: ParseError -> ParseError -> ParseError -> Bool-prop_monoid_assoc x y z = (x <> y) <> z == x <> (y <> z)+prop_monoid_assoc :: PE -> PE -> PE -> Property+prop_monoid_assoc x y z = (x <> y) <> z === x <> (y <> z) -prop_messageString :: Message -> Bool-prop_messageString m@(Unexpected s) = s == messageString m-prop_messageString m@(Expected   s) = s == messageString m-prop_messageString m@(Message    s) = s == messageString m+prop_showReadConsistency :: PE -> Property+prop_showReadConsistency x = read (show x) === x -prop_newErrorMessage :: Message -> SourcePos -> Bool-prop_newErrorMessage msg pos = added && errorPos new == pos-  where new   = newErrorMessage msg pos-        added = errorMessages new == if badMessage msg then [] else [msg]+prop_mergeErrorPos :: PE -> PE -> Property+prop_mergeErrorPos e1 e2 =+  errorPos (e1 <> e2) === max (errorPos e1) (errorPos e2) -prop_wellFormedMessages :: ParseError -> Bool-prop_wellFormedMessages = wellFormed . errorMessages+prop_mergeErrorUnexpected :: PE -> PE -> Property+prop_mergeErrorUnexpected = checkMergedItems errorUnexpected -prop_parseErrorCopy :: ParseError -> Bool-prop_parseErrorCopy err =-  foldr addErrorMessage (newErrorUnknown pos) msgs == err-  where pos  = errorPos err-        msgs = errorMessages err+prop_mergeErrorExpected :: PE -> PE -> Property+prop_mergeErrorExpected = checkMergedItems errorExpected -prop_setErrorPos :: SourcePos -> ParseError -> Bool-prop_setErrorPos pos err =-  errorPos new == pos && errorMessages new == errorMessages err-  where new = setErrorPos pos err+prop_mergeErrorCustom :: PE -> PE -> Property+prop_mergeErrorCustom = checkMergedItems errorCustom -prop_addErrorMessage :: Message -> ParseError -> Bool-prop_addErrorMessage msg err =-  wellFormed msgs && (badMessage msg || added)-  where new   = addErrorMessage msg err-        msgs  = errorMessages new-        added = msg `elem` msgs && not (errorIsUnknown new)+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 -prop_setErrorMessage :: Message -> ParseError -> Bool-prop_setErrorMessage msg err =-  wellFormed msgs && (badMessage msg || (added && unique))-  where new    = setErrorMessage msg err-        msgs   = errorMessages new-        added  = msg `elem` msgs && not (errorIsUnknown new)-        unique = length (filter f msgs) == 1-        f      = fromJust $ find ($ msg) [isUnexpected, isExpected, isMessage]+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\"") ] -prop_mergeErrorPos :: ParseError -> ParseError -> Bool-prop_mergeErrorPos e1 e2 = errorPos (mergeError e1 e2) == max pos1 pos2-  where pos1 = errorPos e1-        pos2 = errorPos e2+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_mergeErrorMsgs :: ParseError -> ParseError -> Bool-prop_mergeErrorMsgs e1 e2' = errorPos e1 /= errorPos e2 || wellFormed msgsm-  where e2    = setErrorPos (errorPos e1) e2'-        msgsm = errorMessages $ mergeError e1 e2+prop_ppSourcePos :: PE -> Property+prop_ppSourcePos = checkPresence errorPos sourcePosPretty -prop_visiblePos :: ParseError -> Bool-prop_visiblePos err = show (errorPos err) `isPrefixOf` show err+prop_ppUnexpected :: PE -> Property+prop_ppUnexpected = checkPresence errorUnexpected showErrorComponent -prop_visibleMsgs :: ParseError -> Bool-prop_visibleMsgs err = if null msgs-                       then "unknown" `isInfixOf` shown-                       else all (`isInfixOf` shown) (msgs >>= f)-  where shown = show err-        msgs  = errorMessages err-        f (Unexpected s) = ["unexpected", s]-        f (Expected   s) = ["expecting",  s]-        f (Message    s) = [s]+prop_ppExpected :: PE -> Property+prop_ppExpected = checkPresence errorExpected showErrorComponent --- | @wellFormed xs@ checks that list @xs@ is sorted and contains no--- duplicates and no empty messages.+prop_ppCustom :: PE -> Property+prop_ppCustom = checkPresence errorCustom showErrorComponent -wellFormed :: [Message] -> Bool-wellFormed xs = and (zipWith (<) xs (tail xs)) && not (any badMessage xs)+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

@@ -26,6 +26,10 @@ -- 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, (<|>))@@ -127,16 +131,16 @@ -- Some helpers are put here since we don't want to depend on -- "Text.Megaparsec.Lexer". -lexeme :: MonadParsec s m Char => m a -> m a+lexeme :: (MonadParsec e s m, Token s ~ Char) => m a -> m a lexeme p = p <* hidden space -symbol :: MonadParsec s m Char => String -> m String+symbol :: (MonadParsec e s m, Token s ~ Char) => String -> m String symbol = lexeme . string -parens :: MonadParsec s m Char => m a -> m a+parens :: (MonadParsec e s m, Token s ~ Char) => m a -> m a parens = between (symbol "(") (symbol ")") -integer :: MonadParsec s m Char => m Integer+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@@ -144,13 +148,13 @@ -- but valid expressions and render them to get their textual -- representation. -expr :: MonadParsec s m Char => m Node+expr :: (MonadParsec e s m, Token s ~ Char) => m Node expr = makeExprParser term table -term :: MonadParsec s m Char => m Node+term :: (MonadParsec e s m, Token s ~ Char) => m Node term = parens expr <|> (Val <$> integer) <?> "term" -table :: MonadParsec s m Char => [[Operator m Node]]+table :: (MonadParsec e s m, Token s ~ Char) => [[Operator m Node]] table = [ [ Prefix  (symbol "-" *> pure Neg)           , Postfix (symbol "!" *> pure Fac)           , InfixN  (symbol "%" *> pure Mod) ]@@ -165,14 +169,14 @@  prop_empty_error :: Property prop_empty_error = checkParser expr r s-  where r = posErr 0 s [uneEof, exSpec "term"]+  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 [uneEof, exSpec "term"]+  where r | c `elem` "-(" = posErr 1 s [ueof, elabel "term"]           | isDigit c     = Right . Val . fromIntegral . digitToInt $ c-          | otherwise     = posErr 0 s [uneCh c, exSpec "term"]+          | otherwise     = posErr 0 s [utok c, elabel "term"]         s = pure c  prop_missing_op :: Node -> Node -> Property@@ -181,5 +185,5 @@         c = s !! n         n = succ $ length a'         r | c == '-'  = Right $ Sub a b-          | otherwise = posErr n s [uneCh c, exEof, exSpec "operator"]+          | otherwise = posErr n s [utok c, eeof, elabel "operator"]         s = a' ++ " " ++ inParens b

@@ -26,7 +26,10 @@ -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -- POSSIBILITY OF SUCH DAMAGE. -{-# LANGUAGE TupleSections #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TupleSections    #-}+{-# LANGUAGE TypeFamilies     #-}  module Lexer (tests) where @@ -41,10 +44,13 @@   , 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@@ -54,7 +60,6 @@ import Text.Megaparsec.String import qualified Text.Megaparsec.Char as C -import Prim () -- 'Arbitrary' instance for 'SourcePos' import Util  #if !MIN_VERSION_base(4,8,0)@@ -66,11 +71,14 @@   [ 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@@ -92,6 +100,10 @@ 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'))]@@ -120,25 +132,25 @@ symbolName = listOf $ arbitrary `suchThat` isAlphaNum  sc :: Parser ()-sc = space (void C.spaceChar) l b+sc = space (void $ C.oneOf " \t") empty empty++scn :: Parser ()+scn = space (void C.spaceChar) l b   where l = skipLineComment "//"         b = skipBlockComment "/*" "*/" -sc' :: Parser ()-sc' = space (void $ C.oneOf " \t") empty empty- prop_space :: Property prop_space = forAll mkWhiteSpace (checkParser p r)-  where p = sc+  where p = scn         r = Right ()  prop_symbol :: Maybe Char -> Property prop_symbol t = forAll mkSymbol $ \s ->-  parseSymbol (symbol sc) id s t+  parseSymbol (symbol scn) id s t  prop_symbol' :: Maybe Char -> Property prop_symbol' t = forAll mkSymbol $ \s ->-  parseSymbol (symbol' sc) (fmap toLower) s t+  parseSymbol (symbol' scn) (fmap toLower) s t  parseSymbol   :: (String -> Parser String)@@ -149,57 +161,76 @@ 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 [uneCh (last s), exEof]+          | 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_indentGuard :: NonNegative Int -> Property+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 | getCol l0 <= 1         = posErr 0 s ii-          | getCol l1 /= getCol l0 = posErr (getIndent l1 + g 1) s ii-          | getCol l2 <= getCol l0 = posErr (getIndent l2 + g 2) s ii-          | otherwise = Right ()+    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 (getNonNegative n)-        p  = ip (> 1) >>= \x -> sp >> ip (== x) >> sp >> ip (> x) >> sp >> sc-        ip = indentGuard sc-        sp = void (symbol sc' sbla <* C.eol)+  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+        | otherwise = posErr i s (ii EQ pos1 (getCol s))   in checkParser p r s-  where p = nonIndented sc (symbol sc sbla)+  where p = nonIndented scn (symbol scn sbla) -prop_indentBlock :: Maybe (Positive Int) -> Property-prop_indentBlock mn' = forAll mkBlock $ \(l0,l1,l2,l3,l4) ->-  let r | getCol l1 <= getCol l0 =-          posErr (getIndent l1 + g 1) s [uneCh (head sblb), exEof]-        | isJust mn && getCol l1 /= ib =-          posErr (getIndent l1 + g 1) s ii-        | getCol l2 <= getCol l1 =-          posErr (getIndent l2 + g 2) s ii-        | getCol l3 == getCol l2 =-          posErr (getIndent l3 + g 3) s [uneCh (head sblb), exStr sblc]-        | getCol l3 <= getCol l0 =-          posErr (getIndent l3 + g 3) s [uneCh (head sblb), exEof]-        | getCol l3 /= getCol l1 =-          posErr (getIndent l3 + g 3) s ii-        | getCol l4 <= getCol l3 =-          posErr (getIndent l4 + g 4) s ii+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@@ -212,48 +243,79 @@           l4 <- mkIndent' sblc (ib + 2)           return (l0,l1,l2,l3,l4)         p = lvla-        lvla = indentBlock sc $ IndentMany mn      (l sbla) lvlb <$ b sbla-        lvlb = indentBlock sc $ IndentSome Nothing (l sblb) lvlc <$ b sblb-        lvlc = indentBlock sc $ IndentNone                  sblc <$ b sblc-        b    = symbol sc'+        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   = getPositive <$> mn'-        ib   = fromMaybe 2 mn+        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 sc $ IndentMany Nothing (l sbla) lvlb <$ b sbla+        lvla = indentBlock scn $ IndentMany Nothing (l sbla) lvlb <$ b sbla         lvlb = b sblb-        b    = symbol sc'+        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 -> Int-getCol x = sourceColumn $+getCol :: String -> Pos+getCol x = sourceColumn .   updatePosString defaultTabWidth (initialPos "") $ take (getIndent x) x  sbla, sblb, sblc :: String-sbla = "xxx"-sblb = "yyy"-sblc = "zzz"+sbla = "aaa"+sblb = "bbb"+sblc = "ccc" -ii :: [Message]-ii = [msg "incorrect indentation"]+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 $ exSpec "literal character" :-                          [ if null s then uneEof else uneCh (head s) ]+        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 [uneCh (head g), exEof]+          | 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) @@ -283,52 +345,58 @@  prop_float_1 :: Maybe (NonNegative Integer) -> Property prop_float_1 n' = checkParser float r s-  where r | isNothing n' = posErr 0 s [uneEof, exSpec "float"]-          | otherwise    = posErr (length s) s [ uneEof, exCh '.', exCh 'E'-                                  , exCh 'e', exSpec "digit" ]+  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 -> Left  $ getNonNegative x-                      Right x -> Right $ getNonNegative x+              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 [uneEof, exSpec "number"]+  where r = posErr 0 s [ueof, elabel "number"]         s = ""  prop_number_2 :: Either Integer Double -> Property-prop_number_2 n = checkParser p (Right n) s+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 $ uneCh '?' :-            (if i <= 0 then [exCh '+', exCh '-'] else []) ++-            [exSpec $ if isNothing . find isDigit $ take i s-                      then "integer"-                      else "rest of integer"] ++-            [exEof | i > head (findIndices isDigit s)]+          | 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 Integer, String)+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 $ uneCh '?' :-            [ exEof | i > 0 ] +++          | otherwise    = posErr i s $ utok '?' :+            [ eeof | i > 0 ] ++             [if i <= 0 || null l-             then exSpec l-             else exSpec $ "rest of " ++ 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

@@ -76,16 +76,16 @@                  <||> char b                  <|?> (c', char c)         r | length bis > 1 && (length cis <= 1 || head bis < head cis) =-              posErr (bis !! 1) s $ [uneCh b, exEof] ++-              [exCh a | a `notElem` preb] ++-              [exCh c | c `notElem` preb]+              posErr (bis !! 1) s $ [utok b, eeof] +++              [etok a | a `notElem` preb] +++              [etok c | c `notElem` preb]           | length cis > 1 =-            posErr (cis !! 1) s $ [uneCh c] ++-            [exCh a | a `notElem` prec] ++-            [if b `elem` prec then exEof else exCh b]-          | b `notElem` s = posErr (length s) s $ [uneEof, exCh b] ++-                            [exCh a | a `notElem` s || last s == a] ++-                            [exCh c | c `notElem` s]+            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' )

@@ -26,132 +26,96 @@ -- 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.Exception (try, evaluate)-import Data.Char (isAlphaNum)-import Data.List (intercalate, isInfixOf, elemIndices)+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 Control.Applicative ((<$>), (<*>), pure)+import Data.Word (Word) #endif  tests :: Test tests = testGroup "Textual source positions"-  [ testProperty "components"                         prop_components-  , testProperty "exception on invalid position"      prop_exception-  , testProperty "show file name in source positions" prop_showFileName-  , testProperty "show line in source positions"      prop_showLine-  , testProperty "show column in source positions"    prop_showColumn-  , testProperty "initial position"                   prop_initialPos-  , testProperty "increment source line"              prop_incSourceLine-  , testProperty "increment source column"            prop_incSourceColumn-  , testProperty "set source name"                    prop_setSourceName-  , testProperty "set source line"                    prop_setSourceLine-  , testProperty "set source column"                  prop_setSourceColumn-  , testProperty "position updating"                  prop_updating ]--instance Arbitrary SourcePos where-  arbitrary = newPos <$> fileName <*> choose (1, 1000) <*> choose (1, 100)--fileName :: Gen String-fileName = do-  delimiter <- pure <$> elements "/\\"-  dirs      <- listOf1 simpleName-  extension <- simpleName-  frequency [ (1, return [])-            , (7, return $ intercalate delimiter dirs ++ "." ++ extension)]-  where simpleName = listOf1 (arbitrary `suchThat` isAlphaNum)--prop_components :: SourcePos -> Bool-prop_components pos = pos == copy-  where copy = newPos (sourceName pos) (sourceLine pos) (sourceColumn pos)--prop_exception :: String -> Int -> Int -> Property-prop_exception file l c = ioProperty $ do-  result <- try . evaluate $ newPos file l c-  return $ r === result-  where r | l < 1 || c < 1 = Left  $ InvalidTextualPosition file l c-          | otherwise      = Right $ newPos file l c+  [ 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_showFileName :: SourcePos -> Bool-prop_showFileName pos = sourceName pos `isInfixOf` show pos+prop_mkPos :: Word -> Property+prop_mkPos x' = case mkPos x' of+  Left  e -> fromException e === Just InvalidPosException+  Right x -> unPos x === x' -prop_showLine :: SourcePos -> Bool-prop_showLine pos = show (sourceLine pos) `isInfixOf` show pos+prop_unsafePos :: Positive Word -> Property+prop_unsafePos x' = unPos (unsafePos x) === x+  where x = getPositive x' -prop_showColumn :: SourcePos -> Bool-prop_showColumn pos = show (sourceColumn pos) `isInfixOf` show pos+prop_showReadPos :: Pos -> Property+prop_showReadPos x = read (show x) === x -prop_initialPos :: String -> Bool-prop_initialPos n =-  sourceName   ipos == n &&-  sourceLine   ipos == 1 &&-  sourceColumn ipos == 1-  where ipos = initialPos n+prop_ordPos :: Pos -> Pos -> Property+prop_ordPos x y = compare x y === (compare `on` unPos) x y -prop_incSourceLine :: SourcePos -> NonNegative Int -> Bool-prop_incSourceLine pos l' =-  d sourceName   id    pos incp &&-  d sourceLine   (+ l) pos incp &&-  d sourceColumn id    pos incp-  where l    = getNonNegative l'-        incp = incSourceLine pos l+prop_semigroupPos :: Pos -> Pos -> Property+prop_semigroupPos x y =+  x <> y === unsafePos (unPos x + unPos y) .&&.+  unPos (x <> y) === unPos x + unPos y -prop_incSourceColumn :: SourcePos -> NonNegative Int -> Bool-prop_incSourceColumn pos c' =-  d sourceName   id    pos incp &&-  d sourceLine   id    pos incp &&-  d sourceColumn (+ c) pos incp-  where c    = getNonNegative c'-        incp = incSourceColumn pos c+prop_initialPos :: String -> Property+prop_initialPos fp =+  sourceName   x === fp          .&&.+  sourceLine   x === unsafePos 1 .&&.+  sourceColumn x === unsafePos 1+  where x = initialPos fp -prop_setSourceName :: SourcePos -> String -> Bool-prop_setSourceName pos n =-  d sourceName   (const n) pos setp &&-  d sourceLine   id        pos setp &&-  d sourceColumn id        pos setp-  where setp = setSourceName pos n+prop_showReadSourcePos :: SourcePos -> Property+prop_showReadSourcePos x = read (show x) === x -prop_setSourceLine :: SourcePos -> Positive Int -> Bool-prop_setSourceLine pos l' =-  d sourceName   id        pos setp &&-  d sourceLine   (const l) pos setp &&-  d sourceColumn id        pos setp-  where l    = getPositive l'-        setp = setSourceLine pos l+prop_ppFilePath :: SourcePos -> Property+prop_ppFilePath x = property $+  sourceName x `isInfixOf` sourcePosPretty x -prop_setSourceColumn :: SourcePos -> Positive Int -> Bool-prop_setSourceColumn pos c' =-  d sourceName   id        pos setp &&-  d sourceLine   id        pos setp &&-  d sourceColumn (const c) pos setp-  where c    = getPositive c'-        setp = setSourceColumn pos c+prop_ppLine :: SourcePos -> Property+prop_ppLine x = property $+  (show . unPos . sourceLine) x `isInfixOf` sourcePosPretty x -prop_updating :: Int -> SourcePos -> String -> Bool-prop_updating w pos "" = updatePosString w pos "" == pos-prop_updating w' pos s =-  d sourceName id           pos updated &&-  d sourceLine (+ inclines) pos updated &&-  cols >= mincols && ((last s /= '\t') || ((cols - 1) `rem` w == 0))-  where w        = if w' < 1 then defaultTabWidth else w'-        updated  = updatePosString w' pos s-        cols     = sourceColumn updated-        newlines = elemIndices '\n' s-        inclines = length newlines-        total    = length s-        mincols  = if null newlines-                   then total + sourceColumn pos-                   else total - maximum newlines+prop_ppColumn :: SourcePos -> Property+prop_ppColumn x = property $+  (show . unPos . sourceColumn) x `isInfixOf` sourcePosPretty x -d :: Eq b => (a -> b) -> (b -> b) -> a -> a -> Bool-d f g x y = g (f x) == f y+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)

@@ -26,25 +26,39 @@ -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -- POSSIBILITY OF SUCH DAMAGE. -{-# LANGUAGE Rank2Types       #-}-{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE Rank2Types        #-}+{-# LANGUAGE RecordWildCards   #-}+{-# LANGUAGE TypeFamilies      #-}+{-# OPTIONS -fno-warn-orphans  #-}  module Prim (tests) where  import Control.Applicative-import Data.Char (isLetter, toUpper)-import Data.Foldable (asum)-import Data.List (isPrefixOf)-import Data.Maybe (maybeToList)- 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)@@ -65,10 +79,22 @@  tests :: Test tests = testGroup "Primitive parser combinators"-  [ testProperty "ParsecT functor"                     prop_functor+  [ 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 (*>)"            prop_applicative_1-  , testProperty "ParsecT applicative (<*)"            prop_applicative_2+  , 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@@ -83,6 +109,7 @@   , 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@@ -120,11 +147,15 @@   , 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+  , 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@@ -138,9 +169,177 @@   , testProperty "StateT notFollowedBy"     prop_StateT_notFollowedBy   , testProperty "WriterT"                  prop_WriterT ] -instance Arbitrary (State String) where-  arbitrary = State <$> arbitrary <*> arbitrary <*> choose (1, 20)+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@@ -152,12 +351,19 @@ prop_applicative_0 :: Integer -> Integer -> Property prop_applicative_0 n m = ((+) <$> pure n <*> pure m) /=\ n + m -prop_applicative_1 :: Integer -> Integer -> Property-prop_applicative_1 n m = (pure n *> pure m) /=\ 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) /=\ n+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@@ -166,9 +372,9 @@ 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 [uneCh (head s1), exEof]) s1+  | null s0  = checkParser p (posErr 0 s1 [utok (head s1), eeof]) s1   | s0 `isPrefixOf` s1 =-      checkParser p (posErr s0l s1 [uneCh (s1 !! s0l), exEof]) 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@@ -177,9 +383,9 @@ 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 [uneCh c, exEof]+          | a == b    = posErr 1 s [utok c, eeof]           | a == c    = Right a-          | otherwise = posErr 1 s [uneCh c, exCh a]+          | otherwise = posErr 1 s [utok c, etok a]         s = if l then [a] else [b,c]  prop_alternative_3 :: Property@@ -196,8 +402,8 @@   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 $ [uneCh 'c', exCh 'b', exEof]-                     ++ [exCh 'a' | b == 0]+          | c > 0  = posErr (a + b) s $ [utok 'c', etok 'b', eeof]+                     ++ [etok 'a' | b == 0]           | otherwise = Right s         s = abcRow a b c @@ -206,11 +412,11 @@ 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 [uneEof, exCh 'a']-          | a == 0 = posErr 0 s [uneCh (head s), exCh 'a']-          | b == 0 = posErr a s $ [exCh 'a', exCh 'b'] ++-                     if c > 0 then [uneCh 'c'] else [uneEof]-          | c > 0 = posErr (a + b) s [uneCh 'c', exCh 'b', exEof]+        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 @@ -218,8 +424,8 @@ 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 $ [uneCh 'c', exEof] ++-                [exCh 'a' | not a && not b] ++ [exCh 'b' | not b]+        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@@ -242,10 +448,9 @@         s = a : b : maybeToList c  prop_monad_3 :: String -> Property-prop_monad_3 m = checkParser p r s-  where p = fail m :: Parser ()-        r | null m    = posErr 0 s []-          | otherwise = posErr 0 s [msg m]+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@@ -262,70 +467,93 @@         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 ask "" "") a === Right a+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+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 L.get "" "") a === Right a+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 (L.put b) "" "") a === b+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 = do x <- callCC $ \e -> when (a > b) (e a) >> return 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 = throwError a >> return b+  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 = (throwError a >> return b) `catchError` handler-        handler e = return $ e + 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 :: String -> Property-prop_unexpected m = checkParser' p r s-  where p :: MonadParsec s m Char => m String-        p = unexpected m-        r = posErr 0 s $ if null m then [] else [uneSpec m]+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 :: [Message] -> Property-prop_failure msgs = checkParser' p r s-  where p :: MonadParsec s m Char => m String-        p = failure msgs-        r | null msgs = posErr 0 s []-          | otherwise = Left $ newErrorMessages msgs (initialPos "")+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 s m Char => m String+  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 $ [uneCh 'c', exEof]-                    ++ [exCh 'a' | b == 0]-                    ++ [if b == 0 || null l-                        then exSpec l-                        else exSpec $ "rest of " ++ l]+          | 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']@@ -333,81 +561,82 @@ prop_hidden_0 :: NonNegative Int -> NonNegative Int               -> NonNegative Int -> Property prop_hidden_0 a' b' c' = checkParser' p r s-  where p :: MonadParsec s m Char => m String+  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 $ [uneCh 'c', exEof]-                     ++ [exCh 'a' | b == 0]+          | 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 s m Char => m (Maybe String)+  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 [uneCh (s !! cn), exEof]-          | otherwise        = posErr 0 s [uneCh (head s), exEof]+          | 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 s m Char => m String+  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 [uneEof, exCh ch1, exCh 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 s m Char => m Char+  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 [uneEof, exSpec "label"]+        r | null s = posErr 0 s [ueof, elabel "label"]           | s == "a" = Right 'a'-          | h == 'b' = posErr 0 s [uneCh 'b', exCh 'a']-          | h == 'c' = posErr 0 s [uneCh 'c', exSpec "label"]-          | otherwise  = posErr 1 s [uneCh (s !! 1), exEof]+          | 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 s m Char => m ()-        p = lookAhead (some letterChar) >> fail "failed"+  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 [uneEof, exSpec "letter"]-          | isLetter h = posErr 0 s [msg "failed"]-          | otherwise  = posErr 0 s [uneCh h, exSpec "letter"]+        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 s m Char => m Char+  where p :: (MonadParsec e s m, Token s ~ Char) => m Char         p = lookAhead (some (char 'a')) >> char 'b'-        r | null s    = posErr 0 s [uneEof, exCh 'a']-          | a         = posErr 0 s [uneCh 'a', exCh 'b']-          | otherwise = posErr 0 s [uneCh (head s), exCh 'a']+        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 s m Char => m String+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 [msg 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 s m Char => m String+  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 [uneCh 'b', exCh 'a']+        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']@@ -415,177 +644,203 @@ prop_notFollowedBy_1 :: NonNegative Int -> NonNegative Int                      -> NonNegative Int -> Property prop_notFollowedBy_1 a' b' c' = checkParser' p r s-  where p :: MonadParsec s m Char => m String+  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 [uneCh 'b', exCh 'a']-          | otherwise       = posErr a s [uneEof, exCh '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 s m Char => m String+  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 [uneEof, exCh '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 s m Char => m ()+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 s m Char => m ()+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 [uneCh 'a', exCh '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 s m Char => m ()+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 s m Char => m ()+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 [uneCh 'a', exCh 'c']+        r = posErr 0 s [utok 'a', etok 'c']         s = "ab" -prop_withRecovery_0 :: NonNegative Int -> NonNegative Int-                    -> NonNegative Int -> Property+prop_withRecovery_0+  :: NonNegative Int+  -> NonNegative Int+  -> NonNegative Int+  -> Property prop_withRecovery_0 a' b' c' = checkParser' p r s   where-    p :: MonadParsec s m Char => m (Either ParseError String)+    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 [uneEof, exCh 'a']-      | a == 0 && b == 0 && c >  3 = posErr 0 s [uneCh 'c', exCh 'a']-      | a == 0 && b == 0           = posErr 0 s [uneCh 'c', exCh 'a']-      | a == 0 && b >  3           = posErr 3 s [uneCh 'b', exCh 'a', exCh 'c']-      | a == 0 &&           c == 0 = posErr b s [uneEof, exCh 'a', exCh 'c']-      | a == 0 &&           c >  3 = posErr (b + 3) s [uneCh 'c', exEof]-      | a == 0                     = Right (posErr 0 s [uneCh 'b', exCh 'a'])-      | a >  3                     = posErr 3 s [uneCh 'a', exCh 'c']-      |           b == 0 && c == 0 = posErr a s $ [uneEof, exCh 'c'] ++ ma-      |           b == 0 && c >  3 = posErr (a + 3) s [uneCh 'c', exEof]+    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 $ [uneCh 'b', exCh 'c'] ++ ma-    ma = [exCh 'a' | a < 3]+      | 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 s m Char => m String+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 s m Char => m String+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 [uneCh 'a', exStr "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 s m Char => m String+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 s m Char => m String+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 [uneCh 'a', exStr "cba", exCh '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 s m Char => m String+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 s m Char => m String+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 [uneEof, exCh 'f']+        r = posErr 3 s [ueof, etok 'f']         s = "abc"  case_withRecovery_5 :: Assertion-case_withRecovery_5 = checkCase p r s-  where p :: MonadParsec s m Char => m String+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 [msg 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 s m Char => m String+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 s m Char => m Char+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 [uneCh 'b', exCh 'd', exCh '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 s m Char => m Char+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 [uneCh 'b', exCh 'd']+        r = posErr 1 s [utok 'b', etok 'd']         s = "abc"  case_eof :: Assertion-case_eof = checkCase eof (Right ()) ""+case_eof = checkCase' eof (Right ()) "" -prop_token :: String -> Property-prop_token s = checkParser' p r s-  where p :: MonadParsec s m Char => m Char-        p = token updatePosChar testChar+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 . pure . Unexpected . showToken $ x+          else Left (E.singleton (Tokens $ nes x), E.empty, E.empty)         h = head s-        r | null s = posErr 0 s [uneEof]+        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 [uneCh (s !! 1), exEof]-          | otherwise = posErr 0 s [uneCh h]+          | isLetter h && length s > 1 = posErr 1 s [utok (s !! 1), eeof]+          | otherwise = posErr 0 s [utok h] -prop_tokens :: String -> String -> Property-prop_tokens a = checkString p a (==) (showToken a)-  where p = tokens updatePosString (==) a+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 :: SourcePos -> Property-prop_state_pos pos = p /=\ pos-  where p = setPosition pos >> getPosition+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@@ -597,16 +852,16 @@           guard (null st1)           return result -prop_state_tab :: Int -> Property+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 String m Char => m (State String)+  where p :: MonadParsec Dec String m => m (State String)         p = do           st <- getParserState-          guard (st == State s (initialPos "") defaultTabWidth)+          guard (st == State s (nes $ initialPos "") defaultTabWidth)           setParserState s1           updateParserState (f s2)           liftM2 const getParserState (setInput "")@@ -616,6 +871,11 @@  -- 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@@ -626,15 +886,15 @@   where p = string s         r = emulateStrParsing st s -emulateStrParsing :: State String-                  -> String-                  -> (State String, Either ParseError String)-emulateStrParsing st@(State i pos t) 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) t, Right s)-  else let uneStuff = if null i then uneEof else uneStr (take (l + 1) i)-       in (st, Left $ newErrorMessages (exStr s : [uneStuff]) pos)-  where l = length $ takeWhile id $ zipWith (==) s i+    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 @@ -645,34 +905,33 @@         nb = getPositive nb'         p = try (many (char 'a') <* many (char 'b') <* char 'c')           <|> (many (char 'a') <* char 'c')-        r = posErr (na + nb) s [exCh 'b', exCh 'c', uneEof]+        r = posErr (na + nb) s [etok 'b', etok 'c', ueof]         s = replicate na 'a' ++ replicate nb 'b' -prop_stOnFail_1 :: Positive Int -> Positive Int -> Property-prop_stOnFail_1 na' t' = runParser' p (stateFromInput s) === (i, r)+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'-        t = getPositive t'-        p = many (char 'a') <* setTabWidth t <* fail myMsg-        r = posErr na s [msg myMsg]+        p = many (char 'a') <* setTabWidth t <* fail emsg+        r = posErr na s [cstm (DecFail emsg)]         s = replicate na 'a'-        myMsg = "failing now!"+        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 [uneCh ch, exEof]+        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 uneEof else uneCh (head s)]+        r = posErr 0 s [if null s then ueof else utok (head s)]         p = notFollowedBy (string s) -stateFromInput :: Stream s t => s -> State s-stateFromInput s = State s (initialPos "") defaultTabWidth+stateFromInput :: s -> State s+stateFromInput s = State s (nes $ initialPos "") defaultTabWidth  -- ReaderT instance of MonadParsec @@ -684,7 +943,7 @@         getS2 = asks snd         p = try (g =<< getS1) <|> (g =<< getS2)         g = sequence . fmap char-        r = posErr 1 s [uneEof, exCh ch1, exCh ch2]+        r = posErr 1 s [ueof, etok ch1, etok ch2]         s = [pre]  prop_ReaderT_notFollowedBy :: NonNegative Int -> NonNegative Int@@ -693,7 +952,7 @@   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 [uneEof, exCh 'a']+          | otherwise      = posErr a s [ueof, etok 'a']         s = abcRow a b c  -- StateT instance of MonadParsec@@ -752,3 +1011,7 @@           void logged_letter'           return cs         r = Right ("ab", pre ++ "AB" ++ post ++ "x")++nes :: a -> NonEmpty a+nes x = x :| []+{-# INLINE nes #-}

@@ -26,38 +26,48 @@ -- ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -- POSSIBILITY OF SUCH DAMAGE. -{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE CPP              #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes       #-}+{-# OPTIONS -fno-warn-orphans #-}  module Util   ( checkParser   , checkParser'   , checkCase+  , checkCase'   , simpleParse   , checkChar   , checkString+  , updatePosString   , (/=\)   , (!=!)   , abcRow+  , EC (..)   , posErr-  , uneCh-  , uneStr-  , uneSpec-  , uneEof-  , exCh-  , exStr-  , exSpec-  , exEof-  , msg-  , showToken )+  , posErr'+  , utok+  , utoks+  , ulabel+  , ueof+  , etok+  , etoks+  , elabel+  , eeof+  , cstm ) where  import Control.Monad.Reader import Control.Monad.Trans.Identity-import Data.Maybe (maybeToList)+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, (@?=))@@ -65,11 +75,10 @@ import Text.Megaparsec.Error import Text.Megaparsec.Pos import Text.Megaparsec.Prim-import Text.Megaparsec.ShowToken import Text.Megaparsec.String  #if !MIN_VERSION_base(4,8,0)-import Control.Applicative ((<$>), (<*))+import Control.Applicative ((<$>), (<*>), (<*)) #endif  -- | @checkParser p r s@ tries to run parser @p@ on input @s@ to parse@@ -78,7 +87,7 @@  checkParser :: (Eq a, Show a)   => Parser a          -- ^ Parser to test-  -> Either ParseError a -- ^ Expected result of parsing+  -> 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@@ -88,8 +97,8 @@ -- combinators.  checkParser' :: (Eq a, Show a)-  => (forall m. MonadParsec String m Char => m a) -- ^ Parser to test-  -> Either ParseError a -- ^ Expected result of parsing+  => (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@@ -104,11 +113,20 @@ -- | Similar to 'checkParser', but produces HUnit's 'Assertion's instead.  checkCase :: (Eq a, Show a)-  => (forall m. MonadParsec String m Char => m a) -- ^ Parser to test-  -> Either ParseError a -- ^ Expected result of parsing+  => 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 = do+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@@ -127,7 +145,7 @@ -- 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 a+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@@ -135,33 +153,51 @@ -- character may be labelled, in this case @label@ is used to check quality -- of error messages. -checkChar :: Parser Char -> (Char -> Bool)-          -> Maybe String -> String -> Property-checkChar p f l' s = checkParser p r s+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-        l = exSpec <$> maybeToList l'-        r | null s = posErr 0 s (uneEof : l)+        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 (uneCh h : l)-          | otherwise = posErr 1 s [uneCh (s !! 1), exEof]+          | 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 -> String -> (Char -> Char -> Bool)-            -> String -> String -> Property-checkString p a' test l s' = checkParser p (w a' 0 s') s'+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' [uneCh s, exEof]-        w _  0 []    = posErr 0 s' [uneEof, exSpec l]-        w _  i []    = posErr 0 s' [uneStr (take i s'), exSpec l]+        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' [uneStr (take i' s'), exSpec l]+          | 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@@ -188,67 +224,144 @@ abcRow a b c = f a 'a' ++ f b 'b' ++ f c 'c'   where f x = replicate (fromEnum x) --- | @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 'uneStr', 'uneCh', 'uneSpec', 'exStr', 'exCh', and--- 'exSpec' for easy ways to create error messages.+-- | A component of parse error, useful for fast and dirty construction of+-- parse errors with 'posErr' and other helpers. -posErr :: Int -> String -> [Message] -> Either ParseError a-posErr pos s = Left . foldr addErrorMessage (newErrorUnknown errPos)-  where errPos = updatePosString defaultTabWidth (initialPos "") (take pos s)+data EC+  = Unexpected (ErrorItem Char)+  | Expected   (ErrorItem Char)+  | Custom     Dec --- | @uneCh s@ returns message created with 'Unexpected' constructor that--- tells the system that char @s@ is unexpected.+instance Arbitrary a => Arbitrary (NonEmpty a) where+  arbitrary = NE.fromList . getNonEmpty <$> arbitrary -uneCh :: Char -> Message-uneCh s = Unexpected $ showToken s+instance Arbitrary t => Arbitrary (ErrorItem t) where+  arbitrary = oneof+    [ Tokens <$> arbitrary+    , Label  <$> arbitrary+    , return EndOfInput ] --- | @uneStr s@ returns message created with 'Unexpected' constructor that--- tells the system that string @s@ is unexpected.+instance Arbitrary Pos where+  arbitrary = unsafePos . getPositive <$> arbitrary -uneStr :: String -> Message-uneStr s = Unexpected $ showToken s+instance Arbitrary SourcePos where+  arbitrary = SourcePos+    <$> shortString+    <*> (unsafePos <$> choose (1, 1000))+    <*> (unsafePos <$> choose (1,  100)) --- | @uneSpec s@ returns message created with 'Unexpected' constructor that--- tells the system that @s@ is unexpected. This is different from 'uneStr'--- in that it doesn't use 'showToken' but rather pass its argument unaltered--- allowing for “special” labels.+instance Arbitrary Dec where+  arbitrary = oneof+    [ DecFail        <$> shortString+    , DecIndentation <$> arbitrary <*> arbitrary <*> arbitrary ] -uneSpec :: String -> Message-uneSpec = Unexpected+instance (Arbitrary t, Ord t, Arbitrary e, Ord e)+    => Arbitrary (ParseError t e) where+  arbitrary = ParseError+    <$> arbitrary+    <*> arbitrary+    <*> arbitrary+    <*> arbitrary --- | @uneEof@ represents message “unexpected end of input”.+shortString :: Gen String+shortString = sized $ \n -> do+  k <- choose (0, n `div` 2)+  vectorOf k arbitrary -uneEof :: Message-uneEof = Unexpected "end of input"+-- | @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. --- | @exCh s@ returns message created with 'Expected' constructor that tells--- the system that character @s@ is expected.+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) -exCh :: Char -> Message-exCh s = Expected $ showToken s+-- | The same as 'posErr', but 'SourcePos' should be provided directly. --- | @exStr s@ returns message created with 'Expected' constructor that tells--- the system that string @s@ is expected.+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 -exStr :: String -> Message-exStr s = Expected $ showToken s+-- | Construct “unexpected token” error component. --- | @exSpec s@ returns message created with 'Expected' constructor that tells--- the system that @s@ is expected. This is different from 'exStr' in that--- it doesn't use 'showToken' but rather pass its argument unaltered--- allowing for “special” labels.+utok :: Char -> EC+utok = Unexpected . Tokens . nes -exSpec :: String -> Message-exSpec = Expected+-- | Construct “unexpected steam” error component. This function respects+-- some conventions described in 'canonicalizeStream'. --- | @exEof@ represents message “expecting end of input”.+utoks :: String -> EC+utoks = Unexpected . canonicalizeStream -exEof :: Message-exEof = Expected "end of input"+-- | Construct “unexpected label” error component. Do not use with empty+-- strings. --- | @msg s@ return message created with 'Message' constructor.+ulabel :: String -> EC+ulabel = Unexpected . Label . NE.fromList -msg :: String -> Message-msg = Message+-- | 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 #-}