diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -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 . -- -- 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 diff --git a/Text/Megaparsec/ByteString.hs b/Text/Megaparsec/ByteString.hs --- a/Text/Megaparsec/ByteString.hs +++ b/Text/Megaparsec/ByteString.hs @@ -1,23 +1,22 @@ -- | -- Module : Text.Megaparsec.ByteString -- Copyright : © 2015–2016 Megaparsec contributors --- © 2007 Paolo Martini -- License : FreeBSD -- -- Maintainer : Mark Karpov -- 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 diff --git a/Text/Megaparsec/ByteString/Lazy.hs b/Text/Megaparsec/ByteString/Lazy.hs --- a/Text/Megaparsec/ByteString/Lazy.hs +++ b/Text/Megaparsec/ByteString/Lazy.hs @@ -1,23 +1,22 @@ -- | -- Module : Text.Megaparsec.ByteString.Lazy -- Copyright : © 2015–2016 Megaparsec contributors --- © 2007 Paolo Martini -- License : FreeBSD -- -- Maintainer : Mark Karpov -- 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 diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs --- a/Text/Megaparsec/Char.hs +++ b/Text/Megaparsec/Char.hs @@ -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 #-} diff --git a/Text/Megaparsec/Combinator.hs b/Text/Megaparsec/Combinator.hs --- a/Text/Megaparsec/Combinator.hs +++ b/Text/Megaparsec/Combinator.hs @@ -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 :: 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 diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs --- a/Text/Megaparsec/Error.hs +++ b/Text/Megaparsec/Error.hs @@ -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 -- 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. diff --git a/Text/Megaparsec/Expr.hs b/Text/Megaparsec/Expr.hs --- a/Text/Megaparsec/Expr.hs +++ b/Text/Megaparsec/Expr.hs @@ -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) diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs --- a/Text/Megaparsec/Lexer.hs +++ b/Text/Megaparsec/Lexer.hs @@ -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) diff --git a/Text/Megaparsec/Perm.hs b/Text/Megaparsec/Perm.hs --- a/Text/Megaparsec/Perm.hs +++ b/Text/Megaparsec/Perm.hs @@ -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 diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs --- a/Text/Megaparsec/Pos.hs +++ b/Text/Megaparsec/Pos.hs @@ -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 -- 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 diff --git a/Text/Megaparsec/Prim.hs b/Text/Megaparsec/Prim.hs --- a/Text/Megaparsec/Prim.hs +++ b/Text/Megaparsec/Prim.hs @@ -7,17 +7,28 @@ -- -- Maintainer : Mark Karpov -- 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 diff --git a/Text/Megaparsec/ShowToken.hs b/Text/Megaparsec/ShowToken.hs deleted file mode 100644 --- a/Text/Megaparsec/ShowToken.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- Module : Text.Megaparsec.ShowToken --- Copyright : © 2015–2016 Megaparsec contributors --- License : FreeBSD --- --- Maintainer : Mark Karpov --- 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 ++ "\"" diff --git a/Text/Megaparsec/String.hs b/Text/Megaparsec/String.hs --- a/Text/Megaparsec/String.hs +++ b/Text/Megaparsec/String.hs @@ -1,22 +1,21 @@ -- | -- Module : Text.Megaparsec.String -- Copyright : © 2015–2016 Megaparsec contributors --- © 2007 Paolo Martini -- License : FreeBSD -- -- Maintainer : Mark Karpov -- 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 diff --git a/Text/Megaparsec/Text.hs b/Text/Megaparsec/Text.hs --- a/Text/Megaparsec/Text.hs +++ b/Text/Megaparsec/Text.hs @@ -1,23 +1,22 @@ -- | -- Module : Text.Megaparsec.Text -- Copyright : © 2015–2016 Megaparsec contributors --- © 2011 Antoine Latter -- License : FreeBSD -- -- Maintainer : Mark Karpov -- 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 diff --git a/Text/Megaparsec/Text/Lazy.hs b/Text/Megaparsec/Text/Lazy.hs --- a/Text/Megaparsec/Text/Lazy.hs +++ b/Text/Megaparsec/Text/Lazy.hs @@ -1,23 +1,22 @@ -- | -- Module : Text.Megaparsec.Text.Lazy -- Copyright : © 2015–2016 Megaparsec contributors --- © 2011 Antoine Latter -- License : FreeBSD -- -- Maintainer : Mark Karpov -- 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 diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -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 diff --git a/old-tests/Bugs.hs b/old-tests/Bugs.hs --- a/old-tests/Bugs.hs +++ b/old-tests/Bugs.hs @@ -1,4 +1,3 @@ - module Bugs (bugs) where import Test.Framework diff --git a/old-tests/Bugs/Bug2.hs b/old-tests/Bugs/Bug2.hs --- a/old-tests/Bugs/Bug2.hs +++ b/old-tests/Bugs/Bug2.hs @@ -1,4 +1,3 @@ - module Bugs.Bug2 (main) where import Control.Applicative (empty) diff --git a/old-tests/Bugs/Bug35.hs b/old-tests/Bugs/Bug35.hs --- a/old-tests/Bugs/Bug35.hs +++ b/old-tests/Bugs/Bug35.hs @@ -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 diff --git a/old-tests/Bugs/Bug39.hs b/old-tests/Bugs/Bug39.hs --- a/old-tests/Bugs/Bug39.hs +++ b/old-tests/Bugs/Bug39.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} module Bugs.Bug39 (main) where diff --git a/old-tests/Bugs/Bug6.hs b/old-tests/Bugs/Bug6.hs --- a/old-tests/Bugs/Bug6.hs +++ b/old-tests/Bugs/Bug6.hs @@ -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 diff --git a/old-tests/Bugs/Bug9.hs b/old-tests/Bugs/Bug9.hs --- a/old-tests/Bugs/Bug9.hs +++ b/old-tests/Bugs/Bug9.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Bugs.Bug9 (main) where import Control.Applicative (empty) diff --git a/old-tests/Main.hs b/old-tests/Main.hs --- a/old-tests/Main.hs +++ b/old-tests/Main.hs @@ -1,4 +1,3 @@ - import Test.Framework import Bugs (bugs) diff --git a/old-tests/Util.hs b/old-tests/Util.hs --- a/old-tests/Util.hs +++ b/old-tests/Util.hs @@ -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 _ -> [] diff --git a/tests/Char.hs b/tests/Char.hs --- a/tests/Char.hs +++ b/tests/Char.hs @@ -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 diff --git a/tests/Combinator.hs b/tests/Combinator.hs --- a/tests/Combinator.hs +++ b/tests/Combinator.hs @@ -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 diff --git a/tests/Error.hs b/tests/Error.hs --- a/tests/Error.hs +++ b/tests/Error.hs @@ -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 diff --git a/tests/Expr.hs b/tests/Expr.hs --- a/tests/Expr.hs +++ b/tests/Expr.hs @@ -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 diff --git a/tests/Lexer.hs b/tests/Lexer.hs --- a/tests/Lexer.hs +++ b/tests/Lexer.hs @@ -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 diff --git a/tests/Perm.hs b/tests/Perm.hs --- a/tests/Perm.hs +++ b/tests/Perm.hs @@ -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' ) diff --git a/tests/Pos.hs b/tests/Pos.hs --- a/tests/Pos.hs +++ b/tests/Pos.hs @@ -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) diff --git a/tests/Prim.hs b/tests/Prim.hs --- a/tests/Prim.hs +++ b/tests/Prim.hs @@ -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 #-} diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -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 #-}