diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,146 @@ -## Megaparec 8.0.0 +*Megaparsec follows [SemVer](https://semver.org/).* +## Megaparsec 9.8.1 + +* Fixed the regression introduced by the fix for the [issue + 572](https://github.com/mrkkrp/megaparsec/issues/572) which caused the + position marker `^` to be missing in certain cases. +* This release officially supports GHC 9.6. This is the oldest GHC version + we support at this time. + +## Megaparsec 9.8.0 + +* Fixed the associativity of the `(<|>)` operator. [Issue + 412](https://github.com/mrkkrp/megaparsec/issues/412). +* Fixed the loss of precision in `decimal`, `binary`, `octal`, and + `hexadecimal` functions in `Text.Megaparsec.Byte.Lexer` and + `Text.Megaparsec.Char.Lexer` when they are used to parse floating point + numbers. [Issue 479](https://github.com/mrkkrp/megaparsec/issues/479). +* Fixed handling of zero-width characters in error messages. To that end, + added `isZeroWidthChar` function in `Text.Megaparsec.Unicode`. [Issue + 572](https://github.com/mrkkrp/megaparsec/issues/572). + +## Megaparsec 9.7.1 + +* Typo fixes and compatibility with `QuickCheck >= 2.17` for + `megaparsec-tests`. + +## Megaparsec 9.7.0 + +* Implemented correct handling of wide Unicode characters in error messages. + To that end, a new module `Text.Megaparsec.Unicode` was introduced. [Issue + 370](https://github.com/mrkkrp/megaparsec/issues/370). +* Inlined `Applicative` operators `(<*)` and `(*>)`. [PR + 566](https://github.com/mrkkrp/megaparsec/pull/566). +* `many` and `some` of the `Alternative` instance of `ParsecT` are now more + efficient, since they use the monadic implementations under the hood. + [Issue 567](https://github.com/mrkkrp/megaparsec/issues/567). +* Added `Text.Megaparsec.Error.errorBundlePrettyForGhcPreProcessors`. [PR + 573](https://github.com/mrkkrp/megaparsec/pull/573). + +## Megaparsec 9.6.1 + +* Exposed `Text.Megaparsec.State`, so that the new functions (`initialState` + and `initialPosState`) can be actually imported from it. [PR + 549](https://github.com/mrkkrp/megaparsec/pull/549). + +## Megaparsec 9.6.0 + +* Added the functions `initialState` and `initialPosState` to + `Text.Megaparsec.State`. [Issue + 449](https://github.com/mrkkrp/megaparsec/issues/449). + +## Megaparsec 9.5.0 + +* Dropped a number of redundant constraints here and there. [PR + 523](https://github.com/mrkkrp/megaparsec/pull/523). + +* Added a `MonadWriter` instance for `ParsecT`. [PR + 534](https://github.com/mrkkrp/megaparsec/pull/534). + +## Megaparsec 9.4.1 + +* Removed `Monad m` constraints in several places where they were introduced + in 9.4.0. [Issue 532](https://github.com/mrkkrp/megaparsec/issues/532). + +## Megaparsec 9.4.0 + +* `dbg` now prints hints among other debug information. [PR + 530](https://github.com/mrkkrp/megaparsec/pull/530). + +* Hints are no longer lost in certain methods of MTL instances for + `ParsecT`. [Issue 528](https://github.com/mrkkrp/megaparsec/issues/528). + +* Added a new method to the `MonadParsec` type class—`mkParsec`. This can be + used to construct “new primitives” with arbitrary behavior at the expense + of having to dive into Megaparsec's internals. [PR + 514](https://github.com/mrkkrp/megaparsec/pull/514). + +## Megaparsec 9.3.1 + +* Fixed a bug related to processing of tabs when error messages are + rendered. [Issue 524](https://github.com/mrkkrp/megaparsec/issues/524). + +## Megaparsec 9.3.0 + +* Now `label` can override more than one group of hints in the parser it + wraps. [Issue 482](https://github.com/mrkkrp/megaparsec/issues/482). + +* `takeP n` now returns the empty chunk of the input stream when `n` is + negative, similar to when `n == 0`. [Issue + 497](https://github.com/mrkkrp/megaparsec/issues/497). + +* Added the `MonadParsecDbg` type class in `Text.Megaparsec.Debug`. The type + class allows us to use `dbg` in MTL monad transformers. [Issue + 488](https://github.com/mrkkrp/megaparsec/issues/488). + +* Introduced the `ShareInput` and `NoShareInput` newtype wrappers in + `Text.Megaparsec.Stream` in order to allow the user to choose how the + input should be sliced and shared during the parsing. [Issue + 492](https://github.com/mrkkrp/megaparsec/issues/492). + +## Megaparsec 9.2.2 + +* Fixed a space leak in the implementations of the `reachOffset` and + `reachOffsetNoLine` methods of `TraversableStream`. [Issue + 486](https://github.com/mrkkrp/megaparsec/issues/486). + +## Megaparsec 9.2.1 + +* Builds with `mtl-2.3` and `transformers-0.6`. + +## Megaparsec 9.2.0 + +* Added parsers for binary representations (little/big endian) of numbers in + `Text.Megaparsec.Byte.Binary`. + +## Megaparsec 9.1.0 + +* Added `dbg'` in `Text.Megaparsec.Debug` for debugging parsers that have + unshowable return values. + +* Documentation improvements. + +## Megaparsec 9.0.1 + +* Added [Safe + Haskell](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/safe_haskell.html) + support. + +## Megaparsec 9.0.0 + +* Split the `Stream` type class. The methods `showTokens` and `tokensLength` + have been put into a separate type class `VisualStream`, while + `reachOffset` and `reachOffsetNoLine` are now in `TraversableStream`. This + should make defining `Stream` instances for custom streams easier. + +* Defined `Stream` instances for lists and `Seq`s. + +* Added the functions `hspace` and `hspace1` to the `Text.Megaparsec.Char` + and `Text.Megaparsec.Byte` modules. + +## Megaparsec 8.0.0 + * The methods `failure` and `fancyFailure` of `MonadParsec` are now ordinary functions and live in `Text.Megaparsec`. They are defined in terms of the new `parseError` method of `MonadParsec`. This method allows us to signal @@ -308,7 +449,7 @@ `Text.Megaparsec.Byte` if you intend to parse binary data, then add qualified modules you need (permutation parsing, lexing, expression parsing, etc.). `Text.Megaparsec.Lexer` was renamed to - `Text.Megaparec.Char.Lexer` because many functions in it has the `Token s + `Text.Megaparsec.Char.Lexer` because many functions in it has the `Token s ~ Char` constraint. There is also `Text.Megaparsec.Byte.Lexer` now, although it has fewer functions. @@ -401,17 +542,17 @@ * Added `notChar` in `Text.Megaparsec.Char`. -* Added `space1` in `Text.Megaprasec.Char`. This parser is like `space` but +* Added `space1` in `Text.Megaparsec.Char`. This parser is like `space` but requires at least one space character to be present to succeed. * Added new module `Text.Megaparsec.Byte`, which is similar to `Text.Megaparsec.Char`, but for token streams of the type `Word8` instead of `Char`. -* `integer` was dropped from `Text.Megaparec.Char.Lexer`. Use `decimal` +* `integer` was dropped from `Text.Megaparsec.Char.Lexer`. Use `decimal` instead. -* `number` was dropped from `Text.Megaparec.Char.Lexer`. Use `scientific` +* `number` was dropped from `Text.Megaparsec.Char.Lexer`. Use `scientific` instead. * `decimal`, `octal`, and `hexadecimal` are now polymorphic in their return @@ -823,7 +964,7 @@ ### Built-in combinators * All built-in combinators in `Text.Megaparsec.Combinator` now work with any - instance of `Alternative` (some of them even with `Applicaitve`). + instance of `Alternative` (some of them even with `Applicative`). * Added more powerful `count'` parser. This parser can be told to parse from `m` to `n` occurrences of some thing. `count` is defined in terms of diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ [![Hackage](https://img.shields.io/hackage/v/megaparsec.svg?style=flat)](https://hackage.haskell.org/package/megaparsec) [![Stackage Nightly](http://stackage.org/package/megaparsec/badge/nightly)](http://stackage.org/nightly/package/megaparsec) [![Stackage LTS](http://stackage.org/package/megaparsec/badge/lts)](http://stackage.org/lts/package/megaparsec) -[![Build Status](https://travis-ci.org/mrkkrp/megaparsec.svg?branch=master)](https://travis-ci.org/mrkkrp/megaparsec) +[![CI](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml/badge.svg)](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml) * [Features](#features) * [Core features](#core-features) @@ -88,16 +88,16 @@ ### Error messages * Megaparsec has typed error messages and the ability to signal custom parse - errors that better suit user's domain of interest. + errors that better suit the user's domain of interest. -* Since version 8, location of parse errors can independent of current +* Since version 8, the location of parse errors can independent of current offset in the input stream. It is useful when you want a parse error to point to a particular position after performing some checks. -* Instead of single parse error Megaparsec produces so-called +* Instead of a single parse error Megaparsec produces so-called `ParseErrorBundle` data type that helps to manage multi-error messages and - pretty-print them easily and efficiently. Since version 8, reporting - multiple parse errors at once has become much easier. + pretty-print them. Since version 8, reporting multiple parse errors at + once has become easier. ### External lexers @@ -139,8 +139,7 @@ You can find the most complete Megaparsec tutorial [here][the-tutorial]. It should provide sufficient guidance to help you start with your parsing -tasks. The site also has instructions and tips for Parsec users who decide -to migrate to Megaparsec. +tasks. ## Performance @@ -160,7 +159,7 @@ You can run the benchmarks yourself by executing: ``` -$ nix-bulid -A benches.parsers-bench +$ nix-build -A benches.parsers-bench $ cd result/bench $ ./bench-memory $ ./bench-speed @@ -185,12 +184,12 @@ matters more than quality of error messages. * *Megaparsec* is good for parsing of source code or other human-readable - texts. It has better error messages and it's implemented as monad + texts. It has better error messages and it's implemented as a monad transformer. -So, if you work with something human-readable where size of input data is -moderate, just go with Megaparsec, otherwise Attoparsec may be a better -choice. +So, if you work with something human-readable where the size of input data +is moderate, it makes sense to go with Megaparsec, otherwise Attoparsec may +be a better choice. ### Megaparsec vs Parsec @@ -209,18 +208,18 @@ * Better support for Unicode parsing in [`Text.Megaparsec.Char`][tm-char]. * Megaparsec has more powerful combinators and can parse languages where - indentation matters out-of-the-box. + indentation matters. * Better documentation. * Megaparsec can recover from parse errors “on the fly” and continue parsing. -* Megaparsec allows us to conditionally process parse errors *inside your - parser* before parsing is finished. In particular, it's possible to define - regions in which parse errors, should they happen, will get a “context - tag”, e.g. we could build a context stack like “in function definition - foo”, “in expression x”, etc. +* Megaparsec allows us to conditionally process parse errors inside a + running parser. In particular, it's possible to define regions in which + parse errors, should they happen, will get a “context tag”, e.g. we could + build a context stack like “in function definition foo”, “in expression + x”, etc. * Megaparsec is faster and supports efficient operations `tokens`, `takeWhileP`, `takeWhile1P`, `takeP`, like Attoparsec. @@ -236,13 +235,12 @@ use: * Complicated, doesn't have any tutorials available, and documentation - doesn't help at all. + doesn't help much. * Trifecta can parse `String` and `ByteString` natively, but not `Text`. * Depends on `lens`, which is a very heavy dependency. If you're not into - `lens` and would like to keep your code “vanilla”, you may not like the - API. + `lens`, you may not like the API. [Idris][idris] has switched from Trifecta to Megaparsec which allowed it to [have better error messages and fewer dependencies][idris-testimony]. @@ -283,6 +281,9 @@ library for easily using [TagSoup](https://hackage.haskell.org/package/tagsoup) as a token type in Megaparsec. +* [`parser-combinators`](https://hackage.haskell.org/package/parser-combinators)—provides permutation and expression parsers [previously bundled with Megaparsec](https://markkarpov.com/post/megaparsec-7.html#parsercombinators-grows-megaparsec-shrinks). +* [`faster-megaparsec`](https://hackage.haskell.org/package/faster-megaparsec)—speeds up parsing + by trying a simple `MonadParsec` instance and falls back to `ParsecT` to report errors. ## Prominent projects that use Megaparsec @@ -330,7 +331,7 @@ Distributed under FreeBSD license. [hackage]: https://hackage.haskell.org/package/megaparsec -[the-tutorial]: https://markkarpov.com/megaparsec/megaparsec.html +[the-tutorial]: https://markkarpov.com/tutorial/megaparsec.html [hacking]: ./HACKING.md [tm]: https://hackage.haskell.org/package/megaparsec/docs/Text-Megaparsec.html diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Text/Megaparsec.hs b/Text/Megaparsec.hs --- a/Text/Megaparsec.hs +++ b/Text/Megaparsec.hs @@ -1,3 +1,12 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec -- Copyright : © 2015–present Megaparsec contributors @@ -11,11 +20,10 @@ -- -- 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 the tutorials --- . +-- at the tutorial . -- -- In addition to the "Text.Megaparsec" module, which exports and re-exports --- most everything that you may need, we advise to import +-- almost everything that you may need, we advise to import -- "Text.Megaparsec.Char" if you plan to work with a stream of 'Char' tokens -- or "Text.Megaparsec.Byte" if you intend to parse binary data. -- @@ -44,92 +52,94 @@ -- like “Type variable @e0@ is ambiguous …”, you need to give an explicit -- signature to your parser to resolve the ambiguity. It's a good idea to -- provide type signatures for all top-level definitions. - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec ( -- * Re-exports -- $reexports - module Text.Megaparsec.Pos - , module Text.Megaparsec.Error - , module Text.Megaparsec.Stream - , module Control.Monad.Combinators + module Text.Megaparsec.Pos, + module Text.Megaparsec.Error, + module Text.Megaparsec.Stream, + module Control.Monad.Combinators, + -- * Data types - , State (..) - , PosState (..) - , Parsec - , ParsecT + State (..), + PosState (..), + Parsec, + ParsecT, + -- * Running parser - , parse - , parseMaybe - , parseTest - , runParser - , runParser' - , runParserT - , runParserT' + parse, + parseMaybe, + parseTest, + runParser, + runParser', + runParserT, + runParserT', + -- * Primitive combinators - , MonadParsec (..) + MonadParsec (..), + -- * Signaling parse errors -- $parse-errors - , failure - , fancyFailure - , unexpected - , customFailure - , region - , registerParseError - , registerFailure - , registerFancyFailure + failure, + fancyFailure, + unexpected, + customFailure, + region, + registerParseError, + registerFailure, + registerFancyFailure, + -- * Derivatives of primitive combinators - , single - , satisfy - , anySingle - , anySingleBut - , oneOf - , noneOf - , chunk - , () - , match - , takeRest - , atEnd + single, + satisfy, + anySingle, + anySingleBut, + oneOf, + noneOf, + chunk, + (), + match, + takeRest, + atEnd, + -- * Parser state combinators - , getInput - , setInput - , getSourcePos - , getOffset - , setOffset - , setParserState ) + getInput, + setInput, + getSourcePos, + getOffset, + setOffset, + setParserState, + ) where import Control.Monad.Combinators import Control.Monad.Identity import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromJust) import Data.Set (Set) +import qualified Data.Set as E import Text.Megaparsec.Class import Text.Megaparsec.Error import Text.Megaparsec.Internal import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -- $reexports -- -- Note that we re-export monadic combinators from -- "Control.Monad.Combinators" because these are more efficient than --- 'Applicative'-based ones. Thus 'many' and 'some' may clash with the +-- 'Applicative'-based ones (†). Thus 'many' and 'some' may clash with the -- functions from "Control.Applicative". You need to hide the functions like -- this: -- -- > import Control.Applicative hiding (many, some) -- +-- † As of Megaparsec 9.7.0 'Control.Applicative.many' and +-- 'Control.Applicative.some' are as efficient as their monadic +-- counterparts. +-- -- Also note that you can import "Control.Monad.Combinators.NonEmpty" if you -- wish that combinators like 'some' return 'NonEmpty' lists. The module -- lives in the @parser-combinators@ package (you need at least version @@ -150,7 +160,6 @@ -- | 'Parsec' is a non-transformer variant of the more general 'ParsecT' -- monad transformer. - type Parsec e s = ParsecT e s Identity ---------------------------------------------------------------------------- @@ -169,12 +178,16 @@ -- > Right xs -> print (sum xs) -- > -- > numbers = decimal `sepBy` char ',' - -parse - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseErrorBundle s e) a +-- +-- 'parse' is the same as 'runParser'. +parse :: + -- | Parser to run + Parsec e s a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + Either (ParseErrorBundle s e) a parse = runParser -- | @'parseMaybe' p input@ runs the parser @p@ on @input@ and returns the @@ -184,28 +197,30 @@ -- -- The function is supposed to be useful for lightweight parsing, where -- error messages (and thus file names) are not important and entire input --- should be parsed. For example, it can be used when parsing of a single --- number according to a specification of its format is desired. - +-- should be consumed. For example, it can be used for parsing of a single +-- number according to a specification of its format. parseMaybe :: (Ord e, Stream s) => Parsec e s a -> s -> Maybe a parseMaybe p s = case parse (p <* eof) "" s of - Left _ -> Nothing + Left _ -> Nothing Right x -> Just x --- | The expression @'parseTest' p input@ applies the parser @p@ against the +-- | The expression @'parseTest' p input@ applies the parser @p@ on the -- input @input@ and prints the result to stdout. Useful for testing. - -parseTest :: ( ShowErrorComponent e - , Show a - , Stream s - ) - => Parsec e s a -- ^ Parser to run - -> s -- ^ Input for parser - -> IO () +parseTest :: + ( ShowErrorComponent e, + Show a, + VisualStream s, + TraversableStream s + ) => + -- | Parser to run + Parsec e s a -> + -- | Input for parser + s -> + IO () parseTest p input = case parse p "" input of - Left e -> putStr (errorBundlePretty e) + Left e -> putStr (errorBundlePretty e) Right x -> print x -- | @'runParser' p file input@ runs parser @p@ on the input stream of @@ -214,25 +229,30 @@ -- 'ParseErrorBundle' ('Left') or a value of type @a@ ('Right'). -- -- > parseFromFile p file = runParser p file <$> readFile file - -runParser - :: Parsec e s a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> Either (ParseErrorBundle s e) a +-- +-- 'runParser' is the same as 'parse'. +runParser :: + -- | Parser to run + Parsec e s a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + Either (ParseErrorBundle s e) a runParser p name s = snd $ runParser' p (initialState name s) -- | The function is similar to 'runParser' with the difference that it --- accepts and returns parser state. This allows to specify arbitrary --- textual position at the beginning of parsing, for example. This is the --- most general way to run a parser over the 'Identity' monad. +-- accepts and returns the parser state. This allows us e.g. to specify +-- arbitrary textual position at the beginning of parsing. This is the most +-- general way to run a parser over the 'Identity' monad. -- -- @since 4.2.0 - -runParser' - :: Parsec e s a -- ^ Parser to run - -> State s e -- ^ Initial state - -> (State s e, Either (ParseErrorBundle s e) a) +runParser' :: + -- | Parser to run + Parsec e s a -> + -- | Initial state + State s e -> + (State s e, Either (ParseErrorBundle s e) a) runParser' p = runIdentity . runParserT' p -- | @'runParserT' p file input@ runs parser @p@ on the input list of tokens @@ -240,12 +260,15 @@ -- messages and may be the empty string. Returns a computation in the -- underlying monad @m@ that returns either a 'ParseErrorBundle' ('Left') or -- a value of type @a@ ('Right'). - -runParserT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> String -- ^ Name of source file - -> s -- ^ Input for parser - -> m (Either (ParseErrorBundle s e) a) +runParserT :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Name of source file + String -> + -- | Input for parser + s -> + m (Either (ParseErrorBundle s e) a) runParserT p name s = snd <$> runParserT' p (initialState name s) -- | This function is similar to 'runParserT', but like 'runParser'' it @@ -253,42 +276,29 @@ -- run a parser. -- -- @since 4.2.0 - -runParserT' :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s e -- ^ Initial state - -> m (State s e, Either (ParseErrorBundle s e) a) +runParserT' :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Initial state + State s e -> + m (State s e, Either (ParseErrorBundle s e) a) runParserT' p s = do (Reply s' _ result) <- runParsecT p s - let toBundle es = ParseErrorBundle - { bundleErrors = - NE.sortWith errorOffset es - , bundlePosState = statePosState s - } + let toBundle es = + ParseErrorBundle + { bundleErrors = + NE.sortWith errorOffset es, + bundlePosState = statePosState s + } return $ case result of - OK x -> + OK _ x -> case NE.nonEmpty (stateParseErrors s') of Nothing -> (s', Right x) Just de -> (s', Left (toBundle de)) Error e -> (s', Left (toBundle (e :| stateParseErrors s'))) --- | Given name of source file and input construct initial state for parser. - -initialState :: String -> s -> State s e -initialState name s = State - { stateInput = s - , stateOffset = 0 - , statePosState = PosState - { pstateInput = s - , pstateOffset = 0 - , pstateSourcePos = initialPos name - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } - , stateParseErrors = [] - } - ---------------------------------------------------------------------------- -- Signaling parse errors @@ -302,12 +312,13 @@ -- | Stop parsing and report a trivial 'ParseError'. -- -- @since 6.0.0 - -failure - :: MonadParsec e s m - => Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any) - -> Set (ErrorItem (Token s)) -- ^ Expected items - -> m a +failure :: + (MonadParsec e s m) => + -- | Unexpected item (if any) + Maybe (ErrorItem (Token s)) -> + -- | Expected items + Set (ErrorItem (Token s)) -> + m a failure us ps = do o <- getOffset parseError (TrivialError o us ps) @@ -317,11 +328,11 @@ -- parse error, see 'Text.Megaparsec.customFailure'. -- -- @since 6.0.0 - -fancyFailure - :: MonadParsec e s m - => Set (ErrorFancy e) -- ^ Fancy error components - -> m a +fancyFailure :: + (MonadParsec e s m) => + -- | Fancy error components + Set (ErrorFancy e) -> + m a fancyFailure xs = do o <- getOffset parseError (FancyError o xs) @@ -331,8 +342,7 @@ -- about unexpected item @item@ without consuming any input. -- -- > unexpected item = failure (Just item) Set.empty - -unexpected :: MonadParsec e s m => ErrorItem (Token s) -> m a +unexpected :: (MonadParsec e s m) => ErrorItem (Token s) -> m a unexpected item = failure (Just item) E.empty {-# INLINE unexpected #-} @@ -342,8 +352,7 @@ -- > customFailure = fancyFailure . Set.singleton . ErrorCustom -- -- @since 6.3.0 - -customFailure :: MonadParsec e s m => e -> m a +customFailure :: (MonadParsec e s m) => e -> m a customFailure = fancyFailure . E.singleton . ErrorCustom {-# INLINE customFailure #-} @@ -351,23 +360,24 @@ -- wrapper. This applies to both normal and delayed 'ParseError's. -- -- As a side-effect of the implementation the inner computation will start --- with empty collection of delayed errors and they will be updated and +-- with an empty collection of delayed errors and they will be updated and -- “restored” on the way out of 'region'. -- -- @since 5.3.0 - -region :: MonadParsec e s m - => (ParseError s e -> ParseError s e) - -- ^ How to process 'ParseError's - -> m a -- ^ The “region” that the processing applies to - -> m a +region :: + (MonadParsec e s m) => + -- | How to process 'ParseError's + (ParseError s e -> ParseError s e) -> + -- | The “region” that the processing applies to + m a -> + m a region f m = do deSoFar <- stateParseErrors <$> getParserState updateParserState $ \s -> - s { stateParseErrors = [] } + s {stateParseErrors = []} r <- observing m updateParserState $ \s -> - s { stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar } + s {stateParseErrors = (f <$> stateParseErrors s) ++ deSoFar} case r of Left err -> parseError (f err) Right x -> return x @@ -376,26 +386,26 @@ -- | Register a 'ParseError' for later reporting. This action does not end -- parsing and has no effect except for adding the given 'ParseError' to the -- collection of “delayed” 'ParseError's which will be taken into --- consideration at the end of parsing. Only if this collection is empty --- parser will succeed. This is the main way to report several parse errors +-- consideration at the end of parsing. Only if this collection is empty will +-- the parser succeed. This is the main way to report several parse errors -- at once. -- -- @since 8.0.0 - -registerParseError :: MonadParsec e s m => ParseError s e -> m () +registerParseError :: (MonadParsec e s m) => ParseError s e -> m () registerParseError e = updateParserState $ \s -> - s { stateParseErrors = e : stateParseErrors s } + s {stateParseErrors = e : stateParseErrors s} {-# INLINE registerParseError #-} -- | Like 'failure', but for delayed 'ParseError's. -- -- @since 8.0.0 - -registerFailure - :: MonadParsec e s m - => Maybe (ErrorItem (Token s)) -- ^ Unexpected item (if any) - -> Set (ErrorItem (Token s)) -- ^ Expected items - -> m () +registerFailure :: + (MonadParsec e s m) => + -- | Unexpected item (if any) + Maybe (ErrorItem (Token s)) -> + -- | Expected items + Set (ErrorItem (Token s)) -> + m () registerFailure us ps = do o <- getOffset registerParseError (TrivialError o us ps) @@ -404,11 +414,11 @@ -- | Like 'fancyFailure', but for delayed 'ParseError's. -- -- @since 8.0.0 - -registerFancyFailure - :: MonadParsec e s m - => Set (ErrorFancy e) -- ^ Fancy error components - -> m () +registerFancyFailure :: + (MonadParsec e s m) => + -- | Fancy error components + Set (ErrorFancy e) -> + m () registerFancyFailure xs = do o <- getOffset registerParseError (FancyError o xs) @@ -425,14 +435,15 @@ -- 'Text.Megaparsec.Char.char'. -- -- @since 7.0.0 - -single :: MonadParsec e s m - => Token s -- ^ Token to match - -> m (Token s) +single :: + (MonadParsec e s m) => + -- | Token to match + Token s -> + m (Token s) single t = token testToken expected where testToken x = if x == t then Just x else Nothing - expected = E.singleton (Tokens (t:|[])) + expected = E.singleton (Tokens (t :| [])) {-# INLINE single #-} -- | The parser @'satisfy' f@ succeeds for any token for which the supplied @@ -441,13 +452,18 @@ -- > digitChar = satisfy isDigit "digit" -- > oneOf cs = satisfy (`elem` cs) -- +-- __Performance note__: when you need to parse a single token, it is often +-- a good idea to use 'satisfy' with the right predicate function instead of +-- creating a complex parser using the combinators. +-- -- See also: 'anySingle', 'anySingleBut', 'oneOf', 'noneOf'. -- -- @since 7.0.0 - -satisfy :: MonadParsec e s m - => (Token s -> Bool) -- ^ Predicate to apply - -> m (Token s) +satisfy :: + (MonadParsec e s m) => + -- | Predicate to apply + (Token s -> Bool) -> + m (Token s) satisfy f = token testChar E.empty where testChar x = if f x then Just x else Nothing @@ -461,8 +477,7 @@ -- See also: 'satisfy', 'anySingleBut'. -- -- @since 7.0.0 - -anySingle :: MonadParsec e s m => m (Token s) +anySingle :: (MonadParsec e s m) => m (Token s) anySingle = satisfy (const True) {-# INLINE anySingle #-} @@ -474,10 +489,11 @@ -- See also: 'single', 'anySingle', 'satisfy'. -- -- @since 7.0.0 - -anySingleBut :: MonadParsec e s m - => Token s -- ^ Token we should not match - -> m (Token s) +anySingleBut :: + (MonadParsec e s m) => + -- | Token we should not match + Token s -> + m (Token s) anySingleBut t = satisfy (/= t) {-# INLINE anySingleBut #-} @@ -499,14 +515,15 @@ -- > quoteSlow = oneOf "'\"" -- -- @since 7.0.0 - -oneOf :: (Foldable f, MonadParsec e s m) - => f (Token s) -- ^ Collection of matching tokens - -> m (Token s) -oneOf cs = satisfy (`elem` cs) +oneOf :: + (Foldable f, MonadParsec e s m) => + -- | Collection of matching tokens + f (Token s) -> + m (Token s) +oneOf cs = satisfy (\x -> elem x cs) {-# INLINE oneOf #-} --- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token +-- | As the dual of 'oneOf', @'noneOf' ts@ succeeds if the current token is -- /not/ in the supplied list of tokens @ts@. Returns the parsed character. -- Note that this parser cannot automatically generate the “expected” -- component of error message, so usually you should label it manually with @@ -520,11 +537,12 @@ -- because it's faster. -- -- @since 7.0.0 - -noneOf :: (Foldable f, MonadParsec e s m) - => f (Token s) -- ^ Collection of taken we should not match - -> m (Token s) -noneOf cs = satisfy (`notElem` cs) +noneOf :: + (Foldable f, MonadParsec e s m) => + -- | Collection of tokens we should not match + f (Token s) -> + m (Token s) +noneOf cs = satisfy (\x -> notElem x cs) {-# INLINE noneOf #-} -- | @'chunk' chk@ only matches the chunk @chk@. @@ -535,18 +553,18 @@ -- 'Text.Megaparsec.Byte.string'. -- -- @since 7.0.0 - -chunk :: MonadParsec e s m - => Tokens s -- ^ Chunk to match - -> m (Tokens s) +chunk :: + (MonadParsec e s m) => + -- | Chunk to match + Tokens s -> + m (Tokens s) chunk = tokens (==) {-# INLINE chunk #-} -- | A synonym for 'label' in the form of an operator. - infix 0 -() :: MonadParsec e s m => m a -> String -> m a +() :: (MonadParsec e s m) => m a -> String -> m a () = flip label {-# INLINE () #-} @@ -556,12 +574,11 @@ -- manually in the argument parser, prepare for troubles. -- -- @since 5.3.0 - -match :: MonadParsec e s m => m a -> m (Tokens s, a) +match :: (MonadParsec e s m) => m a -> m (Tokens s, a) match p = do - o <- getOffset - s <- getInput - r <- p + o <- getOffset + s <- getInput + r <- p o' <- getOffset -- NOTE The 'fromJust' call here should never fail because if the stream -- is empty before 'p' (the only case when 'takeN_' can return 'Nothing' @@ -577,8 +594,7 @@ -- > takeRest = takeWhileP Nothing (const True) -- -- @since 6.0.0 - -takeRest :: MonadParsec e s m => m (Tokens s) +takeRest :: (MonadParsec e s m) => m (Tokens s) takeRest = takeWhileP Nothing (const True) {-# INLINE takeRest #-} @@ -587,8 +603,7 @@ -- > atEnd = option False (True <$ hidden eof) -- -- @since 6.0.0 - -atEnd :: MonadParsec e s m => m Bool +atEnd :: (MonadParsec e s m) => m Bool atEnd = option False (True <$ hidden eof) {-# INLINE atEnd #-} @@ -596,14 +611,12 @@ -- Parser state combinators -- | Return the current input. - -getInput :: MonadParsec e s m => m s +getInput :: (MonadParsec e s m) => m s getInput = stateInput <$> getParserState {-# INLINE getInput #-} -- | @'setInput' input@ continues parsing with @input@. - -setInput :: MonadParsec e s m => s -> m () +setInput :: (MonadParsec e s m) => s -> m () setInput s = updateParserState (\(State _ o pst de) -> State s o pst de) {-# INLINE setInput #-} @@ -616,12 +629,11 @@ -- abuses the library. -- -- @since 7.0.0 - -getSourcePos :: MonadParsec e s m => m SourcePos +getSourcePos :: (TraversableStream s, MonadParsec e s m) => m SourcePos getSourcePos = do st <- getParserState let pst = reachOffsetNoLine (stateOffset st) (statePosState st) - setParserState st { statePosState = pst } + setParserState st {statePosState = pst} return (pstateSourcePos pst) {-# INLINE getSourcePos #-} @@ -630,8 +642,7 @@ -- See also: 'setOffset'. -- -- @since 7.0.0 - -getOffset :: MonadParsec e s m => m Int +getOffset :: (MonadParsec e s m) => m Int getOffset = stateOffset <$> getParserState {-# INLINE getOffset #-} @@ -640,8 +651,7 @@ -- See also: 'getOffset'. -- -- @since 7.0.0 - -setOffset :: MonadParsec e s m => Int -> m () +setOffset :: (MonadParsec e s m) => Int -> m () setOffset o = updateParserState $ \(State s _ pst de) -> State s o pst de {-# INLINE setOffset #-} @@ -649,7 +659,6 @@ -- | @'setParserState' st@ sets the parser state to @st@. -- -- See also: 'getParserState', 'updateParserState'. - -setParserState :: MonadParsec e s m => State s e -> m () +setParserState :: (MonadParsec e s m) => State s e -> m () setParserState st = updateParserState (const st) {-# INLINE setParserState #-} diff --git a/Text/Megaparsec/Byte.hs b/Text/Megaparsec/Byte.hs --- a/Text/Megaparsec/Byte.hs +++ b/Text/Megaparsec/Byte.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Byte -- Copyright : © 2015–present Megaparsec contributors @@ -10,41 +15,43 @@ -- Commonly used binary parsers. -- -- @since 6.0.0 - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Byte ( -- * Simple parsers - newline - , crlf - , eol - , tab - , space - , space1 + newline, + crlf, + eol, + tab, + space, + hspace, + space1, + hspace1, + -- * Categories of characters - , controlChar - , spaceChar - , upperChar - , lowerChar - , letterChar - , alphaNumChar - , printChar - , digitChar - , binDigitChar - , octDigitChar - , hexDigitChar - , asciiChar + controlChar, + spaceChar, + upperChar, + lowerChar, + letterChar, + alphaNumChar, + printChar, + digitChar, + binDigitChar, + octDigitChar, + hexDigitChar, + asciiChar, + -- * Single byte - , char - , char' + char, + char', + -- * Sequence of bytes - , string - , string' ) + string, + string', + ) where import Control.Applicative -import Data.Char hiding (toLower, toUpper) +import Data.Char hiding (isSpace, toLower, toUpper) import Data.Functor (void) import Data.Proxy import Data.Word (Word8) @@ -55,29 +62,26 @@ -- Simple parsers -- | Parse a newline byte. - newline :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) newline = char 10 {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. - crlf :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s) -crlf = string (tokensToChunk (Proxy :: Proxy s) [13,10]) +crlf = string (tokensToChunk (Proxy :: Proxy s) [13, 10]) {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed. - eol :: forall e s m. (MonadParsec e s m, Token s ~ Word8) => m (Tokens s) -eol = (tokenToChunk (Proxy :: Proxy s) <$> newline) - <|> crlf - "end of line" +eol = + (tokenToChunk (Proxy :: Proxy s) <$> newline) + <|> crlf + "end of line" {-# INLINE eol #-} -- | Parse a tab character. - tab :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) tab = char 9 {-# INLINE tab #-} @@ -85,68 +89,72 @@ -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. - space :: (MonadParsec e s m, Token s ~ Word8) => m () -space = void $ takeWhileP (Just "white space") isSpace' +space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace :: (MonadParsec e s m, Token s ~ Word8) => m () +hspace = void $ takeWhileP (Just "white space") isHSpace +{-# INLINE hspace #-} + -- | Skip /one/ or more white space characters. -- -- See also: 'skipSome' and 'spaceChar'. - space1 :: (MonadParsec e s m, Token s ~ Word8) => m () -space1 = void $ takeWhile1P (Just "white space") isSpace' +space1 = void $ takeWhile1P (Just "white space") isSpace {-# INLINE space1 #-} +-- | Like 'space1', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace1 :: (MonadParsec e s m, Token s ~ Word8) => m () +hspace1 = void $ takeWhile1P (Just "white space") isHSpace +{-# INLINE hspace1 #-} + ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character. - controlChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) controlChar = satisfy (isControl . toChar) "control character" {-# INLINE controlChar #-} -- | Parse a space character, and the control characters: tab, newline, -- carriage return, form feed, and vertical tab. - spaceChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) -spaceChar = satisfy isSpace' "white space" +spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} -- | Parse an upper-case character. - upperChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) upperChar = satisfy (isUpper . toChar) "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic character. - lowerChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) lowerChar = satisfy (isLower . toChar) "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic character: lower-case or upper-case. - letterChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) letterChar = satisfy (isLetter . toChar) "letter" {-# INLINE letterChar #-} -- | Parse an alphabetic or digit characters. - alphaNumChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) alphaNumChar = satisfy (isAlphaNum . toChar) "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable character: letter, number, mark, punctuation, symbol -- or space. - printChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) printChar = satisfy (isPrint . toChar) "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”. - digitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) digitChar = satisfy isDigit' "digit" where @@ -156,7 +164,6 @@ -- | Parse a binary digit, i.e. “0” or “1”. -- -- @since 7.0.0 - binDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) binDigitChar = satisfy isBinDigit "binary digit" where @@ -164,7 +171,6 @@ {-# INLINE binDigitChar #-} -- | Parse an octal digit, i.e. between “0” and “7”. - octDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) octDigitChar = satisfy isOctDigit' "octal digit" where @@ -173,14 +179,12 @@ -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. - hexDigitChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) hexDigitChar = satisfy (isHexDigit . toChar) "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. - asciiChar :: (MonadParsec e s m, Token s ~ Word8) => m (Token s) asciiChar = satisfy (< 128) "ASCII character" {-# INLINE asciiChar #-} @@ -191,7 +195,6 @@ -- | A type-constrained version of 'single'. -- -- > newline = char 10 - char :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s) char = single {-# INLINE char #-} @@ -205,35 +208,43 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e' - char' :: (MonadParsec e s m, Token s ~ Word8) => Token s -> m (Token s) -char' c = choice - [ char (toLower c) - , char (toUpper c) - ] +char' c = + choice + [ char (toLower c), + char (toUpper c) + ] {-# INLINE char' #-} ---------------------------------------------------------------------------- -- Helpers --- | 'Word8'-specialized version of 'isSpace'. - -isSpace' :: Word8 -> Bool -isSpace' x +-- | 'Word8'-specialized version of 'Data.Char.isSpace'. +isSpace :: Word8 -> Bool +isSpace x | x >= 9 && x <= 13 = True - | x == 32 = True - | x == 160 = True - | otherwise = False -{-# INLINE isSpace' #-} + | x == 32 = True + | x == 160 = True + | otherwise = False +{-# INLINE isSpace #-} --- | Convert a byte to char. +-- | Like 'isSpace', but does not accept newlines and carriage returns. +isHSpace :: Word8 -> Bool +isHSpace x + | x == 9 = True + | x == 11 = True + | x == 12 = True + | x == 32 = True + | x == 160 = True + | otherwise = False +{-# INLINE isHSpace #-} +-- | Convert a byte to char. toChar :: Word8 -> Char toChar = chr . fromIntegral {-# INLINE toChar #-} -- | Convert a byte to its upper-case version. - toUpper :: Word8 -> Word8 toUpper x | x >= 97 && x <= 122 = x - 32 @@ -244,7 +255,6 @@ {-# INLINE toUpper #-} -- | Convert a byte to its lower-case version. - toLower :: Word8 -> Word8 toLower x | x >= 65 && x <= 90 = x + 32 diff --git a/Text/Megaparsec/Byte/Binary.hs b/Text/Megaparsec/Byte/Binary.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Byte/Binary.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Text.Megaparsec.Byte.Binary +-- Copyright : © 2021–present Megaparsec contributors +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Binary-format number parsers. +-- +-- @since 9.2.0 +module Text.Megaparsec.Byte.Binary + ( -- * Generic parsers + BinaryChunk (..), + anyLE, + anyBE, + + -- * Parsing unsigned values + word8, + word16le, + word16be, + word32le, + word32be, + word64le, + word64be, + + -- * Parsing signed values + int8, + int16le, + int16be, + int32le, + int32be, + int64le, + int64be, + ) +where + +import Data.Bits +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import Data.Int +import Data.Word +import Text.Megaparsec + +-- | Data types that can be converted to little- or big- endian numbers. +class BinaryChunk chunk where + convertChunkBE :: (Bits a, Num a) => chunk -> a + convertChunkLE :: (Bits a, Num a) => chunk -> a + +instance BinaryChunk B.ByteString where + convertChunkBE = B.foldl' go 0 + where + go acc byte = (acc `unsafeShiftL` 8) .|. fromIntegral byte + convertChunkLE = B.foldl' go 0 + where + go acc byte = (acc .|. fromIntegral byte) `rotateR` 8 + +instance BinaryChunk BL.ByteString where + convertChunkBE = BL.foldl' go 0 + where + go acc byte = (acc `unsafeShiftL` 8) .|. fromIntegral byte + convertChunkLE = BL.foldl' go 0 + where + go acc byte = (acc .|. fromIntegral byte) `rotateR` 8 + +---------------------------------------------------------------------------- +-- Generic parsers + +-- | Parse a little-endian number. +-- +-- You may wish to call this with a visible type application: +-- +-- > number <- anyLE (Just "little-endian 32 bit word") @Word32 +anyLE :: + forall a e s m. + (MonadParsec e s m, FiniteBits a, Num a, BinaryChunk (Tokens s)) => + -- | Label, if any + Maybe String -> + m a +anyLE mlabel = convertChunkLE <$> takeP mlabel (finiteByteSize @a) +{-# INLINE anyLE #-} + +-- | Parse a big-endian number. +-- +-- You may wish to call this with a visible type application: +-- +-- > number <- anyBE (Just "big-endian 32 bit word") @Word32 +anyBE :: + forall a e s m. + (MonadParsec e s m, FiniteBits a, Num a, BinaryChunk (Tokens s)) => + -- | Label, if any + Maybe String -> + m a +anyBE mlabel = convertChunkBE <$> takeP mlabel (finiteByteSize @a) +{-# INLINE anyBE #-} + +-------------------------------------------------------------------------------- +-- Parsing unsigned values + +-- | Parse a 'Word8'. +word8 :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word8 +word8 = anyBE (Just "8 bit word") +{-# INLINE word8 #-} + +-- | Parse a little-endian 'Word16'. +word16le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word16 +word16le = anyLE (Just "little-endian 16 bit word") +{-# INLINE word16le #-} + +-- | Parse a big-endian 'Word16'. +word16be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word16 +word16be = anyBE (Just "big-endian 16 bit word") +{-# INLINE word16be #-} + +-- | Parse a little-endian 'Word32'. +word32le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word32 +word32le = anyLE (Just "little-endian 32 bit word") +{-# INLINE word32le #-} + +-- | Parse a big-endian 'Word32'. +word32be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word32 +word32be = anyBE (Just "big-endian 32 bit word") +{-# INLINE word32be #-} + +-- | Parse a little-endian 'Word64'. +word64le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word64 +word64le = anyLE (Just "little-endian 64 word") +{-# INLINE word64le #-} + +-- | Parse a big-endian 'Word64'. +word64be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Word64 +word64be = anyBE (Just "big-endian 64 word") +{-# INLINE word64be #-} + +---------------------------------------------------------------------------- +-- Parsing signed values + +-- | Parse a 'Int8'. +int8 :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int8 +int8 = anyBE (Just "8 bit int") +{-# INLINE int8 #-} + +-- | Parse a little-endian 'Int16'. +int16le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int16 +int16le = anyLE (Just "little-endian 16 bit int") +{-# INLINE int16le #-} + +-- | Parse a big-endian 'Int16'. +int16be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int16 +int16be = anyBE (Just "big-endian 16 bit int") +{-# INLINE int16be #-} + +-- | Parse a little-endian 'Int32'. +int32le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int32 +int32le = anyLE (Just "little-endian 32 bit int") +{-# INLINE int32le #-} + +-- | Parse a big-endian 'Int32'. +int32be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int32 +int32be = anyBE (Just "big-endian 32 bit int") +{-# INLINE int32be #-} + +-- | Parse a little-endian 'Int64'. +int64le :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int64 +int64le = anyLE (Just "little-endian 64 int") +{-# INLINE int64le #-} + +-- | Parse a big-endian 'Int64'. +int64be :: (MonadParsec e s m, BinaryChunk (Tokens s)) => m Int64 +int64be = anyBE (Just "big-endian 64 int") +{-# INLINE int64be #-} + +-------------------------------------------------------------------------------- +-- Helpers + +-- | Return the number of bytes in the argument. +-- +-- Performs ceiling division, so byte-unaligned types (bitsize not a +-- multiple of 8) should work, but further usage is not tested. +finiteByteSize :: forall a. (FiniteBits a) => Int +finiteByteSize = finiteBitSize @a undefined `ceilDiv` 8 + where + ceilDiv x y = (x + y - 1) `div` y +{-# INLINE finiteByteSize #-} diff --git a/Text/Megaparsec/Byte/Lexer.hs b/Text/Megaparsec/Byte/Lexer.hs --- a/Text/Megaparsec/Byte/Lexer.hs +++ b/Text/Megaparsec/Byte/Lexer.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Byte.Lexer -- Copyright : © 2015–present Megaparsec contributors @@ -13,62 +18,63 @@ -- This module is intended to be imported qualified: -- -- > import qualified Text.Megaparsec.Byte.Lexer as L - -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Byte.Lexer ( -- * White space - space - , lexeme - , symbol - , symbol' - , skipLineComment - , skipBlockComment - , skipBlockCommentNested + space, + lexeme, + symbol, + symbol', + skipLineComment, + skipBlockComment, + skipBlockCommentNested, + -- * Numbers - , decimal - , binary - , octal - , hexadecimal - , scientific - , float - , signed ) + decimal, + binary, + octal, + hexadecimal, + scientific, + float, + signed, + ) where import Control.Applicative import Data.Functor (void) -import Data.List (foldl') +import qualified Data.List import Data.Proxy import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci import Data.Word (Word8) import Text.Megaparsec -import Text.Megaparsec.Lexer -import qualified Data.Scientific as Sci import qualified Text.Megaparsec.Byte as B +import Text.Megaparsec.Lexer ---------------------------------------------------------------------------- -- White space --- | Given comment prefix this function returns a parser that skips line +-- | Given a comment prefix this function returns a parser that skips line -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually. - -skipLineComment :: (MonadParsec e s m, Token s ~ Word8) - => Tokens s -- ^ Line comment prefix - -> m () +skipLineComment :: + (MonadParsec e s m, Token s ~ Word8) => + -- | Line comment prefix + Tokens s -> + m () skipLineComment prefix = B.string prefix *> void (takeWhileP (Just "character") (/= 10)) {-# INLINEABLE skipLineComment #-} -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. - -skipBlockComment :: (MonadParsec e s m, Token s ~ Word8) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () +skipBlockComment :: + (MonadParsec e s m) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () skipBlockComment start end = p >> void (manyTill anySingle n) where p = B.string start @@ -79,11 +85,13 @@ -- comment starting with @start@ and ending with @end@. -- -- @since 5.0.0 - -skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Word8) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () +skipBlockCommentNested :: + (MonadParsec e s m, Token s ~ Word8) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () skipBlockCommentNested start end = p >> void (manyTill e n) where e = skipBlockCommentNested start end <|> void anySingle @@ -94,50 +102,55 @@ ---------------------------------------------------------------------------- -- Numbers --- | Parse an integer in decimal representation according to the format of --- integer literals described in the Haskell report. +-- | Parse an integer in the decimal representation according to the format +-- of integer literals described in the Haskell report. -- -- If you need to parse signed integers, see the 'signed' combinator. - -decimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a) - => m a +-- +-- __Warning__: this function does not perform range checks. +decimal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a decimal = decimal_ "integer" {-# INLINEABLE decimal #-} -- | A non-public helper to parse decimal integers. - -decimal_ - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a) - => m a +decimal_ :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a decimal_ = mkNum <$> takeWhile1P (Just "digit") isDigit where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w = a * 10 + fromIntegral (w - 48) {-# INLINE decimal_ #-} --- | Parse an integer in binary representation. Binary number is expected to --- be a non-empty sequence of zeroes “0” and ones “1”. +-- | Parse an integer in the binary representation. The binary number is +-- expected to be a non-empty sequence of zeroes “0” and ones “1”. -- -- You could of course parse some prefix before the actual number: -- -- > binary = char 48 >> char' 98 >> L.binary -- +-- __Warning__: this function does not perform range checks. +-- -- @since 7.0.0 - -binary - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a) - => m a -binary = mkNum - <$> takeWhile1P Nothing isBinDigit - "binary integer" +binary :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a +binary = + mkNum + <$> takeWhile1P Nothing isBinDigit + "binary integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) - step a w = a * 2 + fromIntegral (w - 48) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + step a w = a * 2 + fromIntegral (w - 48) isBinDigit w = w == 48 || w == 49 {-# INLINEABLE binary #-} --- | Parse an integer in octal representation. Representation of octal +-- | Parse an integer in the octal representation. The format of the octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing @@ -146,20 +159,23 @@ -- For example you can make it conform to the Haskell report like this: -- -- > octal = char 48 >> char' 111 >> L.octal - -octal - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a) - => m a -octal = mkNum - <$> takeWhile1P Nothing isOctDigit - "octal integer" +-- +-- __Warning__: this function does not perform range checks. +octal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a +octal = + mkNum + <$> takeWhile1P Nothing isOctDigit + "octal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) - step a w = a * 8 + fromIntegral (w - 48) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + step a w = a * 8 + fromIntegral (w - 48) isOctDigit w = w - 48 < 8 {-# INLINEABLE octal #-} --- | Parse an integer in hexadecimal representation. Representation of +-- | Parse an integer in the hexadecimal representation. The format of the -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before @@ -168,23 +184,26 @@ -- For example you can make it conform to the Haskell report like this: -- -- > hexadecimal = char 48 >> char' 120 >> L.hexadecimal - -hexadecimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Word8, Num a) - => m a -hexadecimal = mkNum - <$> takeWhile1P Nothing isHexDigit - "hexadecimal integer" +-- +-- __Warning__: this function does not perform range checks. +hexadecimal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Word8, Num a) => + m a +hexadecimal = + mkNum + <$> takeWhile1P Nothing isHexDigit + "hexadecimal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a w | w >= 48 && w <= 57 = a * 16 + fromIntegral (w - 48) - | w >= 97 = a * 16 + fromIntegral (w - 87) - | otherwise = a * 16 + fromIntegral (w - 55) + | w >= 97 = a * 16 + fromIntegral (w - 87) + | otherwise = a * 16 + fromIntegral (w - 55) isHexDigit w = - (w >= 48 && w <= 57) || - (w >= 97 && w <= 102) || - (w >= 65 && w <= 70) + (w >= 48 && w <= 57) + || (w >= 97 && w <= 102) + || (w >= 65 && w <= 70) {-# INLINEABLE hexadecimal #-} -- | Parse a floating point value as a 'Scientific' number. 'Scientific' is @@ -197,14 +216,14 @@ -- -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. - -scientific - :: forall e s m. (MonadParsec e s m, Token s ~ Word8) - => m Scientific +scientific :: + forall e s m. + (MonadParsec e s m, Token s ~ Word8) => + m Scientific scientific = do - c' <- decimal_ + c' <- decimal_ SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c') - e <- option e' (try $ exponent_ e') + e <- option e' (try $ exponent_ e') return (Sci.scientific c e) {-# INLINEABLE scientific #-} @@ -216,34 +235,39 @@ -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. -- --- __Note__: in versions 6.0.0–6.1.1 this function accepted plain integers. - +-- __Note__: in versions /6.0.0/–/6.1.1/ this function accepted plain integers. float :: (MonadParsec e s m, Token s ~ Word8, RealFloat a) => m a float = do c' <- decimal_ - Sci.toRealFloat <$> - ((do SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' - e <- option e' (try $ exponent_ e') - return (Sci.scientific c e)) - <|> (Sci.scientific c' <$> exponent_ 0)) + Sci.toRealFloat + <$> ( ( do + SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' + e <- option e' (try $ exponent_ e') + return (Sci.scientific c e) + ) + <|> (Sci.scientific c' <$> exponent_ 0) + ) {-# INLINEABLE float #-} -dotDecimal_ :: (MonadParsec e s m, Token s ~ Word8) - => Proxy s - -> Integer - -> m SP +dotDecimal_ :: + (MonadParsec e s m, Token s ~ Word8) => + Proxy s -> + Integer -> + m SP dotDecimal_ pxy c' = do void (B.char 46) - let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy - step (SP a e') w = SP - (a * 10 + fromIntegral (w - 48)) - (e' - 1) + let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy + step (SP a e') w = + SP + (a * 10 + fromIntegral (w - 48)) + (e' - 1) mkNum <$> takeWhile1P (Just "digit") isDigit {-# INLINE dotDecimal_ #-} -exponent_ :: (MonadParsec e s m, Token s ~ Word8) - => Int - -> m Int +exponent_ :: + (MonadParsec e s m, Token s ~ Word8) => + Int -> + m Int exponent_ e' = do void (B.char' 101) (+ e') <$> signed (return ()) decimal_ @@ -260,11 +284,14 @@ -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal -- > signedInteger = L.signed spaceConsumer integer - -signed :: (MonadParsec e s m, Token s ~ Word8, Num a) - => m () -- ^ How to consume white space after the sign - -> m a -- ^ How to parse the number itself - -> m a -- ^ Parser for signed numbers +signed :: + (MonadParsec e s m, Token s ~ Word8, Num a) => + -- | How to consume white space after the sign + m () -> + -- | How to parse the number itself + m a -> + -- | Parser for signed numbers + m a signed spc p = option id (lexeme spc sign) <*> p where sign = (id <$ B.char 43) <|> (negate <$ B.char 45) @@ -273,8 +300,7 @@ ---------------------------------------------------------------------------- -- Helpers --- | A fast predicate to check if given 'Word8' is a digit in ASCII. - +-- | A fast predicate to check if the given 'Word8' is a digit in ASCII. isDigit :: Word8 -> Bool isDigit w = w - 48 < 10 {-# INLINE isDigit #-} diff --git a/Text/Megaparsec/Char.hs b/Text/Megaparsec/Char.hs --- a/Text/Megaparsec/Char.hs +++ b/Text/Megaparsec/Char.hs @@ -1,3 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Char -- Copyright : © 2015–present Megaparsec contributors @@ -10,47 +17,47 @@ -- Portability : non-portable -- -- Commonly used character parsers. - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Char ( -- * Simple parsers - newline - , crlf - , eol - , tab - , space - , space1 + newline, + crlf, + eol, + tab, + space, + hspace, + space1, + hspace1, + -- * Categories of characters - , controlChar - , spaceChar - , upperChar - , lowerChar - , letterChar - , alphaNumChar - , printChar - , digitChar - , binDigitChar - , octDigitChar - , hexDigitChar - , markChar - , numberChar - , punctuationChar - , symbolChar - , separatorChar - , asciiChar - , latin1Char - , charCategory - , categoryName + controlChar, + spaceChar, + upperChar, + lowerChar, + letterChar, + alphaNumChar, + printChar, + digitChar, + binDigitChar, + octDigitChar, + hexDigitChar, + markChar, + numberChar, + punctuationChar, + symbolChar, + separatorChar, + asciiChar, + latin1Char, + charCategory, + categoryName, + -- * Single character - , char - , char' + char, + char', + -- * Sequence of characters - , string - , string' ) + string, + string', + ) where import Control.Applicative @@ -64,29 +71,26 @@ -- Simple parsers -- | Parse a newline character. - newline :: (MonadParsec e s m, Token s ~ Char) => m (Token s) newline = char '\n' {-# INLINE newline #-} -- | Parse a carriage return character followed by a newline character. -- Return the sequence of characters parsed. - crlf :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) crlf = string (tokensToChunk (Proxy :: Proxy s) "\r\n") {-# INLINE crlf #-} -- | Parse a CRLF (see 'crlf') or LF (see 'newline') end of line. Return the -- sequence of characters parsed. - eol :: forall e s m. (MonadParsec e s m, Token s ~ Char) => m (Tokens s) -eol = (tokenToChunk (Proxy :: Proxy s) <$> newline) - <|> crlf - "end of line" +eol = + (tokenToChunk (Proxy :: Proxy s) <$> newline) + <|> crlf + "end of line" {-# INLINE eol #-} -- | Parse a tab character. - tab :: (MonadParsec e s m, Token s ~ Char) => m (Token s) tab = char '\t' {-# INLINE tab #-} @@ -94,34 +98,44 @@ -- | Skip /zero/ or more white space characters. -- -- See also: 'skipMany' and 'spaceChar'. - space :: (MonadParsec e s m, Token s ~ Char) => m () space = void $ takeWhileP (Just "white space") isSpace {-# INLINE space #-} +-- | Like 'space', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace :: (MonadParsec e s m, Token s ~ Char) => m () +hspace = void $ takeWhileP (Just "white space") isHSpace +{-# INLINE hspace #-} + -- | Skip /one/ or more white space characters. -- -- See also: 'skipSome' and 'spaceChar'. -- -- @since 6.0.0 - space1 :: (MonadParsec e s m, Token s ~ Char) => m () space1 = void $ takeWhile1P (Just "white space") isSpace {-# INLINE space1 #-} +-- | Like 'space1', but does not accept newlines and carriage returns. +-- +-- @since 9.0.0 +hspace1 :: (MonadParsec e s m, Token s ~ Char) => m () +hspace1 = void $ takeWhile1P (Just "white space") isHSpace +{-# INLINE hspace1 #-} + ---------------------------------------------------------------------------- -- Categories of characters -- | Parse a control character (a non-printing character of the Latin-1 -- subset of Unicode). - controlChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) controlChar = satisfy isControl "control character" {-# INLINE controlChar #-} -- | Parse a Unicode space character, and the control characters: tab, -- newline, carriage return, form feed, and vertical tab. - spaceChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) spaceChar = satisfy isSpace "white space" {-# INLINE spaceChar #-} @@ -129,20 +143,17 @@ -- | Parse 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 e s m, Token s ~ Char) => m (Token s) upperChar = satisfy isUpper "uppercase letter" {-# INLINE upperChar #-} -- | Parse a lower-case alphabetic Unicode character. - lowerChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) lowerChar = satisfy isLower "lowercase letter" {-# INLINE lowerChar #-} -- | Parse an alphabetic Unicode character: lower-case, upper-case, or -- title-case letter, or a letter of case-less scripts\/modifier letter. - letterChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) letterChar = satisfy isLetter "letter" {-# INLINE letterChar #-} @@ -152,20 +163,17 @@ -- Note that the numeric digits outside the ASCII range are parsed by this -- 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 e s m, Token s ~ Char) => m (Token s) alphaNumChar = satisfy isAlphaNum "alphanumeric character" {-# INLINE alphaNumChar #-} -- | Parse a printable Unicode character: letter, number, mark, punctuation, -- symbol or space. - printChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) printChar = satisfy isPrint "printable character" {-# INLINE printChar #-} -- | Parse an ASCII digit, i.e between “0” and “9”. - digitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) digitChar = satisfy isDigit "digit" {-# INLINE digitChar #-} @@ -173,7 +181,6 @@ -- | Parse a binary digit, i.e. "0" or "1". -- -- @since 7.0.0 - binDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) binDigitChar = satisfy isBinDigit "binary digit" where @@ -181,109 +188,99 @@ {-# INLINE binDigitChar #-} -- | Parse an octal digit, i.e. between “0” and “7”. - octDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) octDigitChar = satisfy isOctDigit "octal digit" {-# INLINE octDigitChar #-} -- | Parse a hexadecimal digit, i.e. between “0” and “9”, or “a” and “f”, or -- “A” and “F”. - hexDigitChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) hexDigitChar = satisfy isHexDigit "hexadecimal digit" {-# INLINE hexDigitChar #-} -- | Parse a Unicode mark character (accents and the like), which combines -- with preceding characters. - markChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) markChar = satisfy isMark "mark character" {-# INLINE markChar #-} -- | Parse a Unicode numeric character, including digits from various -- scripts, Roman numerals, etc. - numberChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) numberChar = satisfy isNumber "numeric character" {-# INLINE numberChar #-} -- | Parse a Unicode punctuation character, including various kinds of -- connectors, brackets and quotes. - punctuationChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) punctuationChar = satisfy isPunctuation "punctuation" {-# INLINE punctuationChar #-} -- | Parse a Unicode symbol characters, including mathematical and currency -- symbols. - symbolChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) symbolChar = satisfy isSymbol "symbol" {-# INLINE symbolChar #-} -- | Parse a Unicode space and separator characters. - separatorChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) separatorChar = satisfy isSeparator "separator" {-# INLINE separatorChar #-} -- | Parse a character from the first 128 characters of the Unicode -- character set, corresponding to the ASCII character set. - asciiChar :: (MonadParsec e s m, Token s ~ Char) => m (Token s) asciiChar = satisfy isAscii "ASCII character" {-# INLINE asciiChar #-} -- | Parse a character from the first 256 characters of the Unicode -- character set, corresponding to the ISO 8859-1 (Latin-1) character set. - latin1Char :: (MonadParsec e s m, Token s ~ Char) => m (Token s) latin1Char = satisfy isLatin1 "Latin-1 character" {-# INLINE latin1Char #-} -- | @'charCategory' cat@ parses character in Unicode General Category -- @cat@, see 'Data.Char.GeneralCategory'. - -charCategory :: (MonadParsec e s m, Token s ~ Char) - => GeneralCategory - -> m (Token s) +charCategory :: + (MonadParsec e s m, Token s ~ Char) => + GeneralCategory -> + m (Token s) charCategory cat = satisfy ((== cat) . generalCategory) categoryName cat {-# INLINE charCategory #-} -- | Return the human-readable name of Unicode General Category. - categoryName :: GeneralCategory -> String categoryName = \case - UppercaseLetter -> "uppercase letter" - LowercaseLetter -> "lowercase letter" - TitlecaseLetter -> "titlecase letter" - ModifierLetter -> "modifier letter" - OtherLetter -> "other letter" - NonSpacingMark -> "non-spacing mark" + UppercaseLetter -> "uppercase letter" + LowercaseLetter -> "lowercase letter" + TitlecaseLetter -> "titlecase letter" + ModifierLetter -> "modifier letter" + OtherLetter -> "other letter" + NonSpacingMark -> "non-spacing mark" SpacingCombiningMark -> "spacing combining mark" - EnclosingMark -> "enclosing mark" - DecimalNumber -> "decimal number character" - LetterNumber -> "letter number character" - OtherNumber -> "other number character" + EnclosingMark -> "enclosing mark" + DecimalNumber -> "decimal number character" + LetterNumber -> "letter number character" + OtherNumber -> "other number character" ConnectorPunctuation -> "connector punctuation" - DashPunctuation -> "dash punctuation" - OpenPunctuation -> "open punctuation" - ClosePunctuation -> "close punctuation" - InitialQuote -> "initial quote" - FinalQuote -> "final quote" - OtherPunctuation -> "other punctuation" - MathSymbol -> "math symbol" - CurrencySymbol -> "currency symbol" - ModifierSymbol -> "modifier symbol" - OtherSymbol -> "other symbol" - Space -> "white space" - LineSeparator -> "line separator" - ParagraphSeparator -> "paragraph separator" - Control -> "control character" - Format -> "format character" - Surrogate -> "surrogate character" - PrivateUse -> "private-use Unicode character" - NotAssigned -> "non-assigned Unicode character" + DashPunctuation -> "dash punctuation" + OpenPunctuation -> "open punctuation" + ClosePunctuation -> "close punctuation" + InitialQuote -> "initial quote" + FinalQuote -> "final quote" + OtherPunctuation -> "other punctuation" + MathSymbol -> "math symbol" + CurrencySymbol -> "currency symbol" + ModifierSymbol -> "modifier symbol" + OtherSymbol -> "other symbol" + Space -> "white space" + LineSeparator -> "line separator" + ParagraphSeparator -> "paragraph separator" + Control -> "control character" + Format -> "format character" + Surrogate -> "surrogate character" + PrivateUse -> "private-use Unicode character" + NotAssigned -> "non-assigned Unicode character" ---------------------------------------------------------------------------- -- Single character @@ -291,7 +288,6 @@ -- | A type-constrained version of 'single'. -- -- > semicolon = char ';' - char :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) char = single {-# INLINE char #-} @@ -305,11 +301,18 @@ -- 1:1: -- unexpected 'G' -- expecting 'E' or 'e' - char' :: (MonadParsec e s m, Token s ~ Char) => Token s -> m (Token s) -char' c = choice - [ char (toLower c) - , char (toUpper c) - , char (toTitle c) - ] +char' c = + choice + [ char (toLower c), + char (toUpper c), + char (toTitle c) + ] {-# INLINE char' #-} + +---------------------------------------------------------------------------- +-- Helpers + +-- | Is it a horizontal space character? +isHSpace :: Char -> Bool +isHSpace x = isSpace x && x /= '\n' && x /= '\r' diff --git a/Text/Megaparsec/Char/Lexer.hs b/Text/Megaparsec/Char/Lexer.hs --- a/Text/Megaparsec/Char/Lexer.hs +++ b/Text/Megaparsec/Char/Lexer.hs @@ -1,3 +1,10 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + -- | -- Module : Text.Megaparsec.Char.Lexer -- Copyright : © 2015–present Megaparsec contributors @@ -26,77 +33,78 @@ -- > import qualified Text.Megaparsec.Char.Lexer as L -- -- To do lexing of byte streams, see "Text.Megaparsec.Byte.Lexer". - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Char.Lexer ( -- * White space - space - , lexeme - , symbol - , symbol' - , skipLineComment - , skipBlockComment - , skipBlockCommentNested + space, + lexeme, + symbol, + symbol', + skipLineComment, + skipBlockComment, + skipBlockCommentNested, + -- * Indentation - , indentLevel - , incorrectIndent - , indentGuard - , nonIndented - , IndentOpt (..) - , indentBlock - , lineFold + indentLevel, + incorrectIndent, + indentGuard, + nonIndented, + IndentOpt (..), + indentBlock, + lineFold, + -- * Character and string literals - , charLiteral + charLiteral, + -- * Numbers - , decimal - , binary - , octal - , hexadecimal - , scientific - , float - , signed ) + decimal, + binary, + octal, + hexadecimal, + scientific, + float, + signed, + ) where import Control.Applicative import Control.Monad (void) -import Data.List (foldl') +import qualified Data.Char as Char +import qualified Data.List import Data.List.NonEmpty (NonEmpty (..)) -import Data.Maybe (listToMaybe, fromMaybe, isJust) +import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Proxy import Data.Scientific (Scientific) +import qualified Data.Scientific as Sci +import qualified Data.Set as E import Text.Megaparsec -import Text.Megaparsec.Lexer -import qualified Data.Char as Char -import qualified Data.Scientific as Sci -import qualified Data.Set as E import qualified Text.Megaparsec.Char as C +import Text.Megaparsec.Lexer ---------------------------------------------------------------------------- -- White space --- | Given comment prefix this function returns a parser that skips line +-- | Given a comment prefix this function returns a parser that skips line -- comments. Note that it stops just before the newline character but -- doesn't consume the newline. Newline is either supposed to be consumed by -- 'space' parser or picked up manually. - -skipLineComment :: (MonadParsec e s m, Token s ~ Char) - => Tokens s -- ^ Line comment prefix - -> m () +skipLineComment :: + (MonadParsec e s m, Token s ~ Char) => + -- | Line comment prefix + Tokens s -> + m () skipLineComment prefix = C.string prefix *> void (takeWhileP (Just "character") (/= '\n')) {-# INLINEABLE skipLineComment #-} -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. - -skipBlockComment :: (MonadParsec e s m, Token s ~ Char) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () +skipBlockComment :: + (MonadParsec e s m) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () skipBlockComment start end = p >> void (manyTill anySingle n) where p = C.string start @@ -107,11 +115,13 @@ -- comment starting with @start@ and ending with @end@. -- -- @since 5.0.0 - -skipBlockCommentNested :: (MonadParsec e s m, Token s ~ Char) - => Tokens s -- ^ Start of block comment - -> Tokens s -- ^ End of block comment - -> m () +skipBlockCommentNested :: + (MonadParsec e s m, Token s ~ Char) => + -- | Start of block comment + Tokens s -> + -- | End of block comment + Tokens s -> + m () skipBlockCommentNested start end = p >> void (manyTill e n) where e = skipBlockCommentNested start end <|> void anySingle @@ -129,8 +139,7 @@ -- > indentLevel = sourceColumn <$> getPosition -- -- @since 4.3.0 - -indentLevel :: MonadParsec e s m => m Pos +indentLevel :: (TraversableStream s, MonadParsec e s m) => m Pos indentLevel = sourceColumn <$> getSourcePos {-# INLINE indentLevel #-} @@ -142,14 +151,18 @@ -- * 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 = fancyFailure . E.singleton $ - ErrorIndentation ord ref actual +incorrectIndent :: + (MonadParsec e s m) => + -- | Desired ordering between reference level and actual level + Ordering -> + -- | Reference indentation level + Pos -> + -- | Actual indentation level + Pos -> + m a +incorrectIndent ord ref actual = + fancyFailure . E.singleton $ + ErrorIndentation ord ref actual {-# INLINEABLE incorrectIndent #-} -- | @'indentGuard' spaceConsumer ord ref@ first consumes all white space @@ -162,12 +175,16 @@ -- arguments like @'indentGuard' spaceConsumer 'GT' 'pos1'@—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 e s m - => m () -- ^ How to consume indentation (white space) - -> Ordering -- ^ Desired ordering between reference level and actual level - -> Pos -- ^ Reference indentation level - -> m Pos -- ^ Current column (indentation level) +indentGuard :: + (TraversableStream s, MonadParsec e s m) => + -- | How to consume indentation (white space) + m () -> + -- | Desired ordering between reference level and actual level + Ordering -> + -- | Reference indentation level + Pos -> + -- | Current column (indentation level) + m Pos indentGuard sc ord ref = do sc actual <- indentLevel @@ -181,11 +198,13 @@ -- top-level function definitions. -- -- @since 4.3.0 - -nonIndented :: MonadParsec e s m - => m () -- ^ How to consume indentation (white space) - -> m a -- ^ How to parse actual data - -> m a +nonIndented :: + (TraversableStream s, MonadParsec e s m) => + -- | How to consume indentation (white space) + m () -> + -- | How to parse actual data + m a -> + m a nonIndented sc p = indentGuard sc EQ pos1 *> p {-# INLINEABLE nonIndented #-} @@ -193,38 +212,38 @@ -- 'indentBlock', which see. -- -- @since 4.3.0 - data IndentOpt m a b - = IndentNone a - -- ^ Parse no indented tokens, just return the value - | IndentMany (Maybe Pos) ([b] -> m a) (m b) - -- ^ Parse many indented tokens (possibly zero), use given indentation + = -- | Parse no indented tokens, just return the value + IndentNone a + | -- | 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 the final result, and the third -- argument describes how to parse an indented token - | IndentSome (Maybe Pos) ([b] -> m a) (m b) - -- ^ Just like 'IndentMany', but requires at least one indented token to + IndentMany (Maybe Pos) ([b] -> m a) (m b) + | -- | Just like 'IndentMany', but requires at least one indented token to -- be present + IndentSome (Maybe Pos) ([b] -> m a) (m b) --- | Parse a “reference” token and a number of other tokens that have --- greater (but the same) level of indentation than that of “reference” --- token. Reference token can influence parsing, see 'IndentOpt' for more --- information. +-- | Parse a “reference” token and a number of other tokens that have a +-- greater (but the same for all of them) level of indentation than that of +-- the “reference” token. The reference token can influence parsing, see +-- 'IndentOpt' for more information. -- --- Tokens /must not/ consume newlines after them. On the other hand, the --- first argument of this function /must/ consume newlines among other white --- space characters. +-- __Note__: the first argument of this function /must/ consume newlines +-- among other white space characters. -- -- @since 4.3.0 - -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 :: + (TraversableStream s, MonadParsec e s m, Token s ~ Char) => + -- | How to consume indentation (white space) + m () -> + -- | How to parse “reference” token + m (IndentOpt m a b) -> + m a indentBlock sc r = do sc ref <- indentLevel - a <- r + a <- r case a of IndentNone x -> x <$ sc IndentMany indent f p -> do @@ -237,33 +256,41 @@ IndentSome indent f p -> do pos <- C.eol *> indentGuard sc GT ref let lvl = fromMaybe pos indent - x <- if | pos <= ref -> incorrectIndent GT ref pos - | pos == lvl -> p - | otherwise -> incorrectIndent EQ lvl pos - xs <- indentedItems ref lvl sc p - f (x:xs) + x <- + if + | pos <= ref -> incorrectIndent GT ref pos + | pos == lvl -> p + | otherwise -> incorrectIndent EQ lvl pos + xs <- indentedItems ref lvl sc p + f (x : xs) {-# INLINEABLE indentBlock #-} -- | Grab indented items. This is a helper for 'indentBlock', it's not a -- part of the public API. - -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] +indentedItems :: + (TraversableStream s, MonadParsec e s m) => + -- | Reference indentation level + Pos -> + -- | Level of the first indented item ('lookAhead'ed) + Pos -> + -- | How to consume indentation (white space) + m () -> + -- | How to parse indented tokens + m b -> + m [b] indentedItems ref lvl sc p = go where go = do sc - pos <- indentLevel + pos <- indentLevel done <- isJust <$> optional eof if done then return [] - else if | pos <= ref -> return [] - | pos == lvl -> (:) <$> p <*> go - | otherwise -> incorrectIndent EQ lvl pos + else + if + | pos <= ref -> return [] + | pos == lvl -> (:) <$> p <*> go + | otherwise -> incorrectIndent EQ lvl pos -- | Create a parser that supports line-folding. The first argument is used -- to consume white space between components of line fold, thus it /must/ @@ -282,11 +309,13 @@ -- > 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 :: + (TraversableStream s, MonadParsec e s m) => + -- | How to consume indentation (white space) + m () -> + -- | Callback that uses provided space-consumer + (m () -> m a) -> + m a lineFold sc action = sc >> indentLevel >>= action . void . indentGuard sc GT {-# INLINEABLE lineFold #-} @@ -310,7 +339,6 @@ -- -- __Performance note__: the parser is not particularly efficient at the -- moment. - charLiteral :: (MonadParsec e s m, Token s ~ Char) => m Char charLiteral = label "literal character" $ do -- The @~@ is needed to avoid requiring a MonadFail constraint, @@ -318,57 +346,61 @@ r <- lookAhead (count' 1 10 anySingle) case listToMaybe (Char.readLitChar r) of Just (c, r') -> c <$ skipCount (length r - length r') anySingle - Nothing -> unexpected (Tokens (head r:|[])) + Nothing -> unexpected (Tokens (head r :| [])) {-# INLINEABLE charLiteral #-} ---------------------------------------------------------------------------- -- Numbers --- | Parse an integer in decimal representation according to the format of --- integer literals described in the Haskell report. +-- | Parse an integer in the decimal representation according to the format +-- of integer literals described in the Haskell report. -- -- If you need to parse signed integers, see the 'signed' combinator. -- --- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it --- wasn't polymorphic in its return type. - +-- __Note__: before the version /6.0.0/ the function returned 'Integer', +-- i.e. it wasn't polymorphic in its return type. +-- +-- __Warning__: this function does not perform range checks. decimal :: (MonadParsec e s m, Token s ~ Char, Num a) => m a decimal = decimal_ "integer" {-# INLINEABLE decimal #-} -- | A non-public helper to parse decimal integers. - -decimal_ - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a) - => m a +decimal_ :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a decimal_ = mkNum <$> takeWhile1P (Just "digit") Char.isDigit where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 10 + fromIntegral (Char.digitToInt c) {-# INLINE decimal_ #-} --- | Parse an integer in binary representation. Binary number is expected to --- be a non-empty sequence of zeroes “0” and ones “1”. +-- | Parse an integer in binary representation. The binary number is +-- expected to be a non-empty sequence of zeroes “0” and ones “1”. -- -- You could of course parse some prefix before the actual number: -- -- > binary = char '0' >> char' 'b' >> L.binary -- +-- __Warning__: this function does not perform range checks. +-- -- @since 7.0.0 - -binary - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a) - => m a -binary = mkNum - <$> takeWhile1P Nothing isBinDigit - "binary integer" +binary :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a +binary = + mkNum + <$> takeWhile1P Nothing isBinDigit + "binary integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) - step a c = a * 2 + fromIntegral (Char.digitToInt c) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + step a c = a * 2 + fromIntegral (Char.digitToInt c) isBinDigit x = x == '0' || x == '1' {-# INLINEABLE binary #-} --- | Parse an integer in octal representation. Representation of octal +-- | Parse an integer in the octal representation. The format of the octal -- number is expected to be according to the Haskell report except for the -- fact that this parser doesn't parse “0o” or “0O” prefix. It is a -- responsibility of the programmer to parse correct prefix before parsing @@ -378,21 +410,24 @@ -- -- > octal = char '0' >> char' 'o' >> L.octal -- --- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it +-- __Note__: before version /6.0.0/ the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type. - -octal - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a) - => m a -octal = mkNum - <$> takeWhile1P Nothing Char.isOctDigit - "octal integer" +-- +-- __Warning__: this function does not perform range checks. +octal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a +octal = + mkNum + <$> takeWhile1P Nothing Char.isOctDigit + "octal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 8 + fromIntegral (Char.digitToInt c) {-# INLINEABLE octal #-} --- | Parse an integer in hexadecimal representation. Representation of +-- | Parse an integer in the hexadecimal representation. The format of the -- hexadecimal number is expected to be according to the Haskell report -- except for the fact that this parser doesn't parse “0x” or “0X” prefix. -- It is a responsibility of the programmer to parse correct prefix before @@ -402,17 +437,20 @@ -- -- > hexadecimal = char '0' >> char' 'x' >> L.hexadecimal -- --- __Note__: before version 6.0.0 the function returned 'Integer', i.e. it +-- __Note__: before version /6.0.0/ the function returned 'Integer', i.e. it -- wasn't polymorphic in its return type. - -hexadecimal - :: forall e s m a. (MonadParsec e s m, Token s ~ Char, Num a) - => m a -hexadecimal = mkNum - <$> takeWhile1P Nothing Char.isHexDigit - "hexadecimal integer" +-- +-- __Warning__: this function does not perform range checks. +hexadecimal :: + forall e s m a. + (MonadParsec e s m, Token s ~ Char, Num a) => + m a +hexadecimal = + mkNum + <$> takeWhile1P Nothing Char.isHexDigit + "hexadecimal integer" where - mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s) + mkNum = fromInteger . Data.List.foldl' step 0 . chunkToTokens (Proxy :: Proxy s) step a c = a * 16 + fromIntegral (Char.digitToInt c) {-# INLINEABLE hexadecimal #-} @@ -428,14 +466,14 @@ -- see 'signed'. -- -- @since 5.0.0 - -scientific - :: forall e s m. (MonadParsec e s m, Token s ~ Char) - => m Scientific +scientific :: + forall e s m. + (MonadParsec e s m, Token s ~ Char) => + m Scientific scientific = do - c' <- decimal_ + c' <- decimal_ SP c e' <- option (SP c' 0) (try $ dotDecimal_ (Proxy :: Proxy s) c') - e <- option e' (try $ exponent_ e') + e <- option e' (try $ exponent_ e') return (Sci.scientific c e) {-# INLINEABLE scientific #-} @@ -447,46 +485,52 @@ -- This function does not parse sign, if you need to parse signed numbers, -- see 'signed'. -- --- __Note__: before version 6.0.0 the function returned 'Double', i.e. it +-- __Note__: before version /6.0.0/ the function returned 'Double', i.e. it -- wasn't polymorphic in its return type. -- --- __Note__: in versions 6.0.0–6.1.1 this function accepted plain integers. - +-- __Note__: in versions /6.0.0/–/6.1.1/ this function accepted plain +-- integers. float :: (MonadParsec e s m, Token s ~ Char, RealFloat a) => m a float = do c' <- decimal_ - Sci.toRealFloat <$> - ((do SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' - e <- option e' (try $ exponent_ e') - return (Sci.scientific c e)) - <|> (Sci.scientific c' <$> exponent_ 0)) + Sci.toRealFloat + <$> ( ( do + SP c e' <- dotDecimal_ (Proxy :: Proxy s) c' + e <- option e' (try $ exponent_ e') + return (Sci.scientific c e) + ) + <|> (Sci.scientific c' <$> exponent_ 0) + ) {-# INLINEABLE float #-} -dotDecimal_ :: (MonadParsec e s m, Token s ~ Char) - => Proxy s - -> Integer - -> m SP +dotDecimal_ :: + (MonadParsec e s m, Token s ~ Char) => + Proxy s -> + Integer -> + m SP dotDecimal_ pxy c' = do void (C.char '.') - let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy - step (SP a e') c = SP - (a * 10 + fromIntegral (Char.digitToInt c)) - (e' - 1) + let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy + step (SP a e') c = + SP + (a * 10 + fromIntegral (Char.digitToInt c)) + (e' - 1) mkNum <$> takeWhile1P (Just "digit") Char.isDigit {-# INLINE dotDecimal_ #-} -exponent_ :: (MonadParsec e s m, Token s ~ Char) - => Int - -> m Int +exponent_ :: + (MonadParsec e s m, Token s ~ Char) => + Int -> + m Int exponent_ e' = do void (C.char' 'e') (+ e') <$> signed (return ()) decimal_ {-# INLINE exponent_ #-} --- | @'signed' space p@ parser parses an optional sign character (“+” or --- “-”), then if there is a sign it consumes optional white space (using --- @space@ parser), then it runs parser @p@ which should return a number. --- Sign of the number is changed according to the previously parsed sign +-- | @'signed' space p@ parses an optional sign character (“+” or “-”), then +-- if there is a sign it consumes optional white space (using the @space@ +-- parser), then it runs the parser @p@ which should return a number. Sign +-- of the number is changed according to the previously parsed sign -- character. -- -- For example, to parse signed integer you can write: @@ -494,11 +538,14 @@ -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal -- > signedInteger = L.signed spaceConsumer integer - -signed :: (MonadParsec e s m, Token s ~ Char, Num a) - => m () -- ^ How to consume white space after the sign - -> m a -- ^ How to parse the number itself - -> m a -- ^ Parser for signed numbers +signed :: + (MonadParsec e s m, Token s ~ Char, Num a) => + -- | How to consume white space after the sign + m () -> + -- | How to parse the number itself + m a -> + -- | Parser for signed numbers + m a signed spc p = option id (lexeme spc sign) <*> p where sign = (id <$ C.char '+') <|> (negate <$ C.char '-') diff --git a/Text/Megaparsec/Class.hs b/Text/Megaparsec/Class.hs --- a/Text/Megaparsec/Class.hs +++ b/Text/Megaparsec/Class.hs @@ -1,3 +1,10 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Class -- Copyright : © 2015–present Megaparsec contributors @@ -13,31 +20,26 @@ -- the full set of primitive parsers. -- -- @since 6.5.0 - -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec.Class - ( MonadParsec (..) ) + ( MonadParsec (..), + ) where import Control.Monad import Control.Monad.Identity +import qualified Control.Monad.RWS.Lazy as L +import qualified Control.Monad.RWS.Strict as S import Control.Monad.Trans +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 Data.Set (Set) import Text.Megaparsec.Error +import {-# SOURCE #-} Text.Megaparsec.Internal (Reply) import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Control.Monad.RWS.Lazy as L -import qualified Control.Monad.RWS.Strict as S -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 -- | Type class describing monads that implement the full set of primitive -- parsers. @@ -45,32 +47,27 @@ -- __Note__ that the following primitives are “fast” and should be taken -- advantage of as much as possible if your aim is a fast parser: 'tokens', -- 'takeWhileP', 'takeWhile1P', and 'takeP'. - class (Stream s, MonadPlus m) => MonadParsec e s m | m -> e s where - -- | Stop parsing and report the 'ParseError'. This is the only way to - -- control position of the error without manipulating parser state + -- control position of the error without manipulating the parser state -- manually. -- -- @since 8.0.0 - parseError :: ParseError s e -> 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 -- “expected” tokens with the name @name@. - label :: String -> m a -> m a -- | @'hidden' p@ behaves just like parser @p@, but it doesn't show any -- “expected” tokens in error message when @p@ fails. -- -- Please use 'hidden' instead of the old @'label' ""@ idiom. - hidden :: m a -> m a hidden = label "" - -- | The parser @'try' p@ behaves like parser @p@, except that it + -- | The parser @'try' p@ behaves like the parser @p@, except that it -- backtracks the parser state when @p@ fails (either consuming input or -- not). -- @@ -108,7 +105,6 @@ -- However, the examples above demonstrate the idea behind 'try' so well -- that it was decided to keep them. You still need to use 'try' when your -- alternatives are complex, composite parsers. - try :: m a -> m a -- | If @p@ in @'lookAhead' p@ succeeds (either consuming input or not) @@ -116,69 +112,67 @@ -- (parser state is not updated as well). If @p@ fails, 'lookAhead' has no -- effect, i.e. it will fail consuming input if @p@ fails consuming input. -- Combine with 'try' if this is undesirable. - lookAhead :: m a -> m a -- | @'notFollowedBy' p@ only succeeds when the parser @p@ fails. This -- parser /never consumes/ any input and /never modifies/ parser state. It -- can be used to implement the “longest match” rule. - notFollowedBy :: m a -> m () - -- | @'withRecovery' r p@ allows continue parsing even if parser @p@ - -- fails. In this case @r@ is called with the actual 'ParseError' as its - -- argument. Typical usage is to return a value signifying failure to + -- | @'withRecovery' r p@ allows us to continue parsing even if the parser + -- @p@ fails. In this case @r@ is called with the actual 'ParseError' as + -- its argument. Typical usage is to return a value signifying failure to -- parse this particular object and to consume some part of the input up -- to the point where the next object starts. -- - -- Note that if @r@ fails, original error message is reported as if - -- without 'withRecovery'. In no way recovering parser @r@ can influence + -- Note that if @r@ fails, the original error message is reported as if + -- without 'withRecovery'. In no way can the recovering parser @r@ influence -- error messages. -- -- @since 4.4.0 - - withRecovery - :: (ParseError s e -> m a) -- ^ How to recover from failure - -> m a -- ^ Original parser - -> m a -- ^ Parser that can recover from failures + withRecovery :: + -- | How to recover from failure + (ParseError s e -> m a) -> + -- | Original parser + m a -> + -- | Parser that can recover from failures + m a - -- | @'observing' p@ allows to “observe” failure of the @p@ parser, should - -- it happen, without actually ending parsing but instead getting the - -- 'ParseError' in 'Left'. On success parsed value is returned in 'Right' - -- as usual. Note that this primitive just allows you to observe parse - -- errors as they happen, it does not backtrack or change how the @p@ - -- parser works in any way. + -- | @'observing' p@ allows us to “observe” failure of the @p@ parser, + -- should it happen, without actually ending parsing but instead getting + -- the 'ParseError' in 'Left'. On success parsed value is returned in + -- 'Right' as usual. Note that this primitive just allows you to observe + -- parse errors as they happen, it does not backtrack or change how the + -- @p@ parser works in any way. -- -- @since 5.1.0 - - observing - :: m a -- ^ The parser to run - -> m (Either (ParseError s e) a) + observing :: + -- | The parser to run + m a -> + m (Either (ParseError s e) a) -- | This parser only succeeds at the end of input. - eof :: m () - -- | The parser @'token' test expected@ accepts a token @t@ with result - -- @x@ when the function @test t@ returns @'Just' x@. @expected@ specifies - -- the collection of expected items to report in error messages. + -- | The parser @'token' test expected@ accepts tokens for which the + -- matching function @test@ returns 'Just' results. If 'Nothing' is + -- returned the @expected@ set is used to report the items that were + -- expected. -- - -- This is the most primitive combinator for accepting tokens. For - -- example, the 'Text.Megaparsec.satisfy' parser is implemented as: + -- For example, the 'Text.Megaparsec.satisfy' parser is implemented as: -- - -- > satisfy f = token testToken E.empty + -- > satisfy f = token testToken Set.empty -- > where -- > testToken x = if f x then Just x else Nothing -- -- __Note__: type signature of this primitive was changed in the version -- /7.0.0/. - - token - :: (Token s -> Maybe a) - -- ^ Matching function for the token to parse - -> Set (ErrorItem (Token s)) - -- ^ Expected items (in case of an error) - -> m a + token :: + -- | Matching function for the token to parse + (Token s -> Maybe a) -> + -- | Used in the error message to mention the items that were expected + Set (ErrorItem (Token s)) -> + m a -- | The parser @'tokens' test chk@ parses a chunk of input @chk@ and -- returns it. The supplied predicate @test@ is used to check equality of @@ -204,252 +198,282 @@ -- with 'tokens'-based parsers, such as 'Text.Megaparsec.Char.string' and -- 'Text.Megaparsec.Char.string''. This feature /does not/ affect -- performance in any way. - - tokens - :: (Tokens s -> Tokens s -> Bool) - -- ^ Predicate to check equality of chunks - -> Tokens s - -- ^ Chunk of input to match against - -> m (Tokens s) + tokens :: + -- | Predicate to check equality of chunks + (Tokens s -> Tokens s -> Bool) -> + -- | Chunk of input to match against + Tokens s -> + m (Tokens s) -- | Parse /zero/ or more tokens for which the supplied predicate holds. - -- Try to use this as much as possible because for many streams the + -- Try to use this as much as possible because for many streams this -- combinator is much faster than parsers built with -- 'Control.Monad.Combinators.many' and 'Text.Megaparsec.satisfy'. -- - -- The following equations should clarify the behavior: - -- -- > takeWhileP (Just "foo") f = many (satisfy f "foo") -- > takeWhileP Nothing f = many (satisfy f) -- -- The combinator never fails, although it may parse the empty chunk. -- -- @since 6.0.0 - - takeWhileP - :: Maybe String -- ^ Name for a single token in the row - -> (Token s -> Bool) -- ^ Predicate to use to test tokens - -> m (Tokens s) -- ^ A chunk of matching tokens + takeWhileP :: + -- | Name for a single token in the row + Maybe String -> + -- | Predicate to use to test tokens + (Token s -> Bool) -> + -- | A chunk of matching tokens + m (Tokens s) -- | Similar to 'takeWhileP', but fails if it can't parse at least one - -- token. Note that the combinator either succeeds or fails without - -- consuming any input, so 'try' is not necessary with it. + -- token. Try to use this as much as possible because for many streams + -- this combinator is much faster than parsers built with + -- 'Control.Monad.Combinators.some' and 'Text.Megaparsec.satisfy'. -- + -- > takeWhile1P (Just "foo") f = some (satisfy f "foo") + -- > takeWhile1P Nothing f = some (satisfy f) + -- + -- Note that the combinator either succeeds or fails without consuming any + -- input, so 'try' is not necessary with it. + -- -- @since 6.0.0 - - takeWhile1P - :: Maybe String -- ^ Name for a single token in the row - -> (Token s -> Bool) -- ^ Predicate to use to test tokens - -> m (Tokens s) -- ^ A chunk of matching tokens + takeWhile1P :: + -- | Name for a single token in the row + Maybe String -> + -- | Predicate to use to test tokens + (Token s -> Bool) -> + -- | A chunk of matching tokens + m (Tokens s) -- | Extract the specified number of tokens from the input stream and - -- return them packed as a chunk of stream. If there is not enough tokens + -- return them packed as a chunk of stream. If there are not enough tokens -- in the stream, a parse error will be signaled. It's guaranteed that if -- the parser succeeds, the requested number of tokens will be returned. -- -- The parser is roughly equivalent to: -- - -- > takeP (Just "foo") n = count n (anyChar "foo") - -- > takeP Nothing n = count n anyChar + -- > takeP (Just "foo") n = count n (anySingle "foo") + -- > takeP Nothing n = count n anySingle -- -- Note that if the combinator fails due to insufficient number of tokens -- in the input stream, it backtracks automatically. No 'try' is necessary -- with 'takeP'. -- -- @since 6.0.0 - - takeP - :: Maybe String -- ^ Name for a single token in the row - -> Int -- ^ How many tokens to extract - -> m (Tokens s) -- ^ A chunk of matching tokens + takeP :: + -- | Name for a single token in the row + Maybe String -> + -- | How many tokens to extract + Int -> + -- | A chunk of matching tokens + m (Tokens s) -- | Return the full parser state as a 'State' record. - getParserState :: m (State s e) -- | @'updateParserState' f@ applies the function @f@ to the parser state. - updateParserState :: (State s e -> State s e) -> m () + -- | An escape hatch for defining custom 'MonadParsec' primitives. You + -- will need to import "Text.Megaparsec.Internal" in order to construct + -- 'Reply'. + -- + -- @since 9.4.0 + mkParsec :: (State s e -> Reply e s a) -> m a + ---------------------------------------------------------------------------- -- Lifting through MTL -instance MonadParsec e s m => MonadParsec e s (L.StateT st m) where - parseError e = lift (parseError e) - 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 -> +instance (MonadParsec e s m) => MonadParsec e s (L.StateT st m) where + parseError e = lift (parseError e) + 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 -> (,s) . fst <$> lookAhead (m s) notFollowedBy (L.StateT m) = L.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) + notFollowedBy (fst <$> m s) >> return ((), s) withRecovery r (L.StateT m) = L.StateT $ \s -> withRecovery (\e -> L.runStateT (r e) s) (m s) - observing (L.StateT m) = L.StateT $ \s -> + observing (L.StateT m) = L.StateT $ \s -> fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (S.StateT st m) where - parseError e = lift (parseError e) - 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 -> +instance (MonadParsec e s m) => MonadParsec e s (S.StateT st m) where + parseError e = lift (parseError e) + 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 -> (,s) . fst <$> lookAhead (m s) notFollowedBy (S.StateT m) = S.StateT $ \s -> - notFollowedBy (fst <$> m s) >> return ((),s) + notFollowedBy (fst <$> m s) >> return ((), s) withRecovery r (S.StateT m) = S.StateT $ \s -> withRecovery (\e -> S.runStateT (r e) s) (m s) - observing (S.StateT m) = S.StateT $ \s -> + observing (S.StateT m) = S.StateT $ \s -> fixs s <$> observing (m s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (L.ReaderT r m) where - parseError e = lift (parseError e) - 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 +instance (MonadParsec e s m) => MonadParsec e s (L.ReaderT r m) where + parseError e = lift (parseError e) + 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 notFollowedBy (L.ReaderT m) = L.ReaderT $ notFollowedBy . m withRecovery r (L.ReaderT m) = L.ReaderT $ \s -> withRecovery (\e -> L.runReaderT (r e) s) (m s) - observing (L.ReaderT m) = L.ReaderT $ observing . m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + observing (L.ReaderT m) = L.ReaderT $ observing . m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.WriterT w m) where - parseError e = lift (parseError e) - label n (L.WriterT m) = L.WriterT $ label n m - try (L.WriterT m) = L.WriterT $ try m - lookAhead (L.WriterT m) = L.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (L.WriterT m) = L.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (L.WriterT m) = L.WriterT $ - withRecovery (L.runWriterT . r) m - observing (L.WriterT m) = L.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + parseError e = lift (parseError e) + label n (L.WriterT m) = L.WriterT $ label n m + try (L.WriterT m) = L.WriterT $ try m + lookAhead (L.WriterT m) = + L.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (L.WriterT m) = + L.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + withRecovery r (L.WriterT m) = + L.WriterT $ + withRecovery (L.runWriterT . r) m + observing (L.WriterT m) = + L.WriterT $ + fixs mempty <$> observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.WriterT w m) where - parseError e = lift (parseError e) - label n (S.WriterT m) = S.WriterT $ label n m - try (S.WriterT m) = S.WriterT $ try m - lookAhead (S.WriterT m) = S.WriterT $ - (,mempty) . fst <$> lookAhead m - notFollowedBy (S.WriterT m) = S.WriterT $ - (,mempty) <$> notFollowedBy (fst <$> m) - withRecovery r (S.WriterT m) = S.WriterT $ - withRecovery (S.runWriterT . r) m - observing (S.WriterT m) = S.WriterT $ - fixs mempty <$> observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + parseError e = lift (parseError e) + label n (S.WriterT m) = S.WriterT $ label n m + try (S.WriterT m) = S.WriterT $ try m + lookAhead (S.WriterT m) = + S.WriterT $ + (,mempty) . fst <$> lookAhead m + notFollowedBy (S.WriterT m) = + S.WriterT $ + (,mempty) <$> notFollowedBy (fst <$> m) + withRecovery r (S.WriterT m) = + S.WriterT $ + withRecovery (S.runWriterT . r) m + observing (S.WriterT m) = + S.WriterT $ + fixs mempty <$> observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -- | @since 5.2.0 - instance (Monoid w, MonadParsec e s m) => MonadParsec e s (L.RWST r w st m) where - parseError e = lift (parseError e) - label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) - try (L.RWST m) = L.RWST $ \r s -> try (m r s) - lookAhead (L.RWST m) = L.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (L.RWST m) = L.RWST $ \r s -> do + parseError e = lift (parseError e) + label n (L.RWST m) = L.RWST $ \r s -> label n (m r s) + try (L.RWST m) = L.RWST $ \r s -> try (m r s) + lookAhead (L.RWST m) = L.RWST $ \r s -> do + (x, _, _) <- lookAhead (m r s) + return (x, s, mempty) + notFollowedBy (L.RWST m) = L.RWST $ \r s -> do notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (L.RWST m) = L.RWST $ \r s -> + return ((), s, mempty) + withRecovery n (L.RWST m) = L.RWST $ \r s -> withRecovery (\e -> L.runRWST (n e) r s) (m r s) - observing (L.RWST m) = L.RWST $ \r s -> + observing (L.RWST m) = L.RWST $ \r s -> fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -- | @since 5.2.0 - instance (Monoid w, MonadParsec e s m) => MonadParsec e s (S.RWST r w st m) where - parseError e = lift (parseError e) - label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) - try (S.RWST m) = S.RWST $ \r s -> try (m r s) - lookAhead (S.RWST m) = S.RWST $ \r s -> do - (x,_,_) <- lookAhead (m r s) - return (x,s,mempty) - notFollowedBy (S.RWST m) = S.RWST $ \r s -> do + parseError e = lift (parseError e) + label n (S.RWST m) = S.RWST $ \r s -> label n (m r s) + try (S.RWST m) = S.RWST $ \r s -> try (m r s) + lookAhead (S.RWST m) = S.RWST $ \r s -> do + (x, _, _) <- lookAhead (m r s) + return (x, s, mempty) + notFollowedBy (S.RWST m) = S.RWST $ \r s -> do notFollowedBy (void $ m r s) - return ((),s,mempty) - withRecovery n (S.RWST m) = S.RWST $ \r s -> + return ((), s, mempty) + withRecovery n (S.RWST m) = S.RWST $ \r s -> withRecovery (\e -> S.runRWST (n e) r s) (m r s) - observing (S.RWST m) = S.RWST $ \r s -> + observing (S.RWST m) = S.RWST $ \r s -> fixs' s <$> observing (m r s) - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift (tokens e ts) - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift (updateParserState f) + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift (tokens e ts) + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift (updateParserState f) + mkParsec f = lift (mkParsec f) -instance MonadParsec e s m => MonadParsec e s (IdentityT m) where - parseError e = lift (parseError e) - label n (IdentityT m) = IdentityT $ label n m - try = IdentityT . try . runIdentityT - lookAhead (IdentityT m) = IdentityT $ lookAhead m +instance (MonadParsec e s m) => MonadParsec e s (IdentityT m) where + parseError e = lift (parseError e) + label n (IdentityT m) = IdentityT $ label n m + try = IdentityT . try . runIdentityT + lookAhead (IdentityT m) = IdentityT $ lookAhead m notFollowedBy (IdentityT m) = IdentityT $ notFollowedBy m - withRecovery r (IdentityT m) = IdentityT $ - withRecovery (runIdentityT . r) m - observing (IdentityT m) = IdentityT $ observing m - eof = lift eof - token test mt = lift (token test mt) - tokens e ts = lift $ tokens e ts - takeWhileP l f = lift (takeWhileP l f) - takeWhile1P l f = lift (takeWhile1P l f) - takeP l n = lift (takeP l n) - getParserState = lift getParserState - updateParserState f = lift $ updateParserState f + withRecovery r (IdentityT m) = + IdentityT $ + withRecovery (runIdentityT . r) m + observing (IdentityT m) = IdentityT $ observing m + eof = lift eof + token test mt = lift (token test mt) + tokens e ts = lift $ tokens e ts + takeWhileP l f = lift (takeWhileP l f) + takeWhile1P l f = lift (takeWhile1P l f) + takeP l n = lift (takeP l n) + getParserState = lift getParserState + updateParserState f = lift $ updateParserState f + mkParsec f = lift (mkParsec f) fixs :: s -> Either a (b, s) -> (Either a b, s) -fixs s (Left a) = (Left a, s) +fixs s (Left a) = (Left a, s) fixs _ (Right (b, s)) = (Right b, s) {-# INLINE fixs #-} -fixs' :: Monoid w => s -> Either a (b, s, w) -> (Either a b, s, w) -fixs' s (Left a) = (Left a, s, mempty) -fixs' _ (Right (b,s,w)) = (Right b, s, w) +fixs' :: (Monoid w) => s -> Either a (b, s, w) -> (Either a b, s, w) +fixs' s (Left a) = (Left a, s, mempty) +fixs' _ (Right (b, s, w)) = (Right b, s, w) {-# INLINE fixs' #-} diff --git a/Text/Megaparsec/Common.hs b/Text/Megaparsec/Common.hs --- a/Text/Megaparsec/Common.hs +++ b/Text/Megaparsec/Common.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} + -- | -- Module : Text.Megaparsec.Common -- Copyright : © 2018–present Megaparsec contributors @@ -11,32 +14,29 @@ -- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char". -- -- @since 7.0.0 - -{-# LANGUAGE FlexibleContexts #-} - module Text.Megaparsec.Common - ( string - , string' ) + ( string, + string', + ) where +import qualified Data.CaseInsensitive as CI import Data.Function (on) import Text.Megaparsec -import qualified Data.CaseInsensitive as CI -- | A synonym for 'chunk'. - -string :: MonadParsec e s m => Tokens s -> m (Tokens s) +string :: (MonadParsec e s m) => Tokens s -> m (Tokens s) string = chunk {-# INLINE string #-} -- | The same as 'string', but case-insensitive. On success returns string --- cased as actually parsed input. +-- cased as the parsed input. -- -- >>> parseTest (string' "foobar") "foObAr" -- "foObAr" - -string' :: (MonadParsec e s m, CI.FoldCase (Tokens s)) - => Tokens s - -> m (Tokens s) +string' :: + (MonadParsec e s m, CI.FoldCase (Tokens s)) => + Tokens s -> + m (Tokens s) string' = tokens ((==) `on` CI.mk) {-# INLINE string' #-} diff --git a/Text/Megaparsec/Debug.hs b/Text/Megaparsec/Debug.hs --- a/Text/Megaparsec/Debug.hs +++ b/Text/Megaparsec/Debug.hs @@ -1,3 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Unsafe #-} + -- | -- Module : Text.Megaparsec.Debug -- Copyright : © 2015–present Megaparsec contributors @@ -10,130 +16,318 @@ -- Debugging helpers. -- -- @since 7.0.0 - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Text.Megaparsec.Debug - ( dbg ) + ( MonadParsecDbg (..), + dbg', + ) where +import Control.Monad.Identity (IdentityT, mapIdentityT) +import qualified Control.Monad.Trans.RWS.Lazy as L +import qualified Control.Monad.Trans.RWS.Strict as S +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 Data.Bifunctor (Bifunctor (first)) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NE import Data.Proxy +import qualified Data.Set as E import Debug.Trace +import Text.Megaparsec.Class (MonadParsec) import Text.Megaparsec.Error import Text.Megaparsec.Internal import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE --- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated --- it also prints information useful for debugging. The @label@ is only used --- to refer to this parser in the debugging output. This combinator uses the --- 'trace' function from "Debug.Trace" under the hood. +-- | Type class describing parser monads that can trace during evaluation. -- --- Typical usage is to wrap every sub-parser in misbehaving parser with --- 'dbg' assigning meaningful labels. Then give it a shot and go through the --- print-out. As of current version, this combinator prints all available --- information except for /hints/, which are probably only interesting to --- the maintainer of Megaparsec itself and may be quite verbose to output in --- general. Let me know if you would like to be able to see hints in the --- debugging output. +-- @since 9.3.0 +class (MonadParsec e s m) => MonadParsecDbg e s m where + -- | @'dbg' label p@ parser works exactly like @p@, but when it's evaluated + -- it prints information useful for debugging. The @label@ is only used to + -- refer to this parser in the debugging output. This combinator uses the + -- 'trace' function from "Debug.Trace" under the hood. + -- + -- Typical usage is to wrap every sub-parser in misbehaving parser with + -- 'dbg' assigning meaningful labels. Then give it a shot and go through the + -- print-out. As of current version, this combinator prints all available + -- information except for /hints/, which are probably only interesting to + -- the maintainer of Megaparsec itself and may be quite verbose to output in + -- general. Let me know if you would like to be able to see hints in the + -- debugging output. + -- + -- The output itself is pretty self-explanatory, although the following + -- abbreviations should be clarified (they are derived from the low-level + -- source code): + -- + -- * @COK@—“consumed OK”. The parser consumed input and succeeded. + -- * @CERR@—“consumed error”. The parser consumed input and failed. + -- * @EOK@—“empty OK”. The parser succeeded without consuming input. + -- * @EERR@—“empty error”. The parser failed without consuming input. + -- + -- __Note__: up until the version /9.3.0/ this was a non-polymorphic + -- function that worked only in 'ParsecT'. It was first introduced in the + -- version /7.0.0/. + dbg :: + (Show a) => + -- | Debugging label + String -> + -- | Parser to debug + m a -> + -- | Parser that prints debugging messages + m a + +-- | @dbg (p :: StateT st m)@ prints state __after__ running @p@: -- --- The output itself is pretty self-explanatory, although the following --- abbreviations should be clarified (they are derived from the low-level --- source code): +-- >>> p = modify succ >> dbg "a" (single 'a' >> modify succ) +-- >>> parseTest (runStateT p 0) "a" +-- a> IN: 'a' +-- a> MATCH (COK): 'a' +-- a> VALUE: () (STATE: 2) +-- ((),2) +instance + (Show st, MonadParsecDbg e s m) => + MonadParsecDbg e s (L.StateT st m) + where + dbg str sma = L.StateT $ \s -> + dbgWithComment "STATE" str $ L.runStateT sma s + +-- | @dbg (p :: StateT st m)@ prints state __after__ running @p@: -- --- * @COK@—“consumed OK”. The parser consumed input and succeeded. --- * @CERR@—“consumed error”. The parser consumed input and failed. --- * @EOK@—“empty OK”. The parser succeeded without consuming input. --- * @EERR@—“empty error”. The parser failed without consuming input. +-- >>> p = modify succ >> dbg "a" (single 'a' >> modify succ) +-- >>> parseTest (runStateT p 0) "a" +-- a> IN: 'a' +-- a> MATCH (COK): 'a' +-- a> VALUE: () (STATE: 2) +-- ((),2) +instance + (Show st, MonadParsecDbg e s m) => + MonadParsecDbg e s (S.StateT st m) + where + dbg str sma = S.StateT $ \s -> + dbgWithComment "STATE" str $ S.runStateT sma s + +instance + (MonadParsecDbg e s m) => + MonadParsecDbg e s (L.ReaderT r m) + where + dbg = L.mapReaderT . dbg + +-- | @dbg (p :: WriterT st m)@ prints __only__ log produced by @p@: -- --- Finally, it's not possible to lift this function into some monad --- transformers without introducing surprising behavior (e.g. unexpected --- state backtracking) or adding otherwise redundant constraints (e.g. --- 'Show' instance for state), so this helper is only available for --- 'ParsecT' monad, not any instance of 'Text.Megaparsec.MonadParsec' in --- general. +-- >>> p = tell [0] >> dbg "a" (single 'a' >> tell [1]) +-- >>> parseTest (runWriterT p) "a" +-- a> IN: 'a' +-- a> MATCH (COK): 'a' +-- a> VALUE: () (LOG: [1]) +-- ((),[0,1]) +instance + (Monoid w, Show w, MonadParsecDbg e s m) => + MonadParsecDbg e s (L.WriterT w m) + where + dbg str wma = L.WriterT $ dbgWithComment "LOG" str $ L.runWriterT wma -dbg :: forall e s m a. - ( Stream s - , ShowErrorComponent e - , Show a ) - => String -- ^ Debugging label - -> ParsecT e s m a -- ^ Parser to debug - -> ParsecT e s m a -- ^ Parser that prints debugging messages -dbg lbl p = ParsecT $ \s cok cerr eok eerr -> - let l = dbgLog lbl :: DbgItem s e a -> String - unfold = streamTake 40 - cok' x s' hs = flip trace (cok x s' hs) $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x) - cerr' err s' = flip trace (cerr err s') $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err) - eok' x s' hs = flip trace (eok x s' hs) $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x) - eerr' err s' = flip trace (eerr err s') $ - l (DbgIn (unfold (stateInput s))) ++ - l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err) - in unParser p s cok' cerr' eok' eerr' +-- | @dbg (p :: WriterT st m)@ prints __only__ log produced by @p@: +-- +-- >>> p = tell [0] >> dbg "a" (single 'a' >> tell [1]) +-- >>> parseTest (runWriterT p) "a" +-- a> IN: 'a' +-- a> MATCH (COK): 'a' +-- a> VALUE: () (LOG: [1]) +-- ((),[0,1]) +instance + (Monoid w, Show w, MonadParsecDbg e s m) => + MonadParsecDbg e s (S.WriterT w m) + where + dbg str wma = S.WriterT $ dbgWithComment "LOG" str $ S.runWriterT wma --- | A single piece of info to be rendered with 'dbgLog'. +-- | @RWST@ works like @StateT@ inside a @WriterT@: subparser's log and its +-- final state is printed: +-- +-- >>> p = tell [0] >> modify succ >> dbg "a" (single 'a' >> tell [1] >> modify succ) +-- >>> parseTest (runRWST p () 0) "a" +-- a> IN: 'a' +-- a> MATCH (COK): 'a' +-- a> VALUE: () (STATE: 2) (LOG: [1]) +-- ((),2,[0,1]) +instance + (Monoid w, Show w, Show st, MonadParsecDbg e s m) => + MonadParsecDbg e s (L.RWST r w st m) + where + dbg str sma = L.RWST $ \r s -> do + let smth = + (\(a, st, w) -> ShowComment "LOG" (ShowComment "STATE" (a, st), w)) + <$> L.runRWST sma r s + ((a, st), w) <- first unComment . unComment <$> dbg str smth + pure (a, st, w) +-- | @RWST@ works like @StateT@ inside a @WriterT@: subparser's log and its +-- final state is printed: +-- +-- >>> p = tell [0] >> modify succ >> dbg "a" (single 'a' >> tell [1] >> modify succ) +-- >>> parseTest (runRWST p () 0) "a" +-- a> IN: 'a' +-- a> MATCH (COK): 'a' +-- a> VALUE: () (STATE: 2) (LOG: [1]) +-- ((),2,[0,1]) +instance + (Monoid w, Show w, Show st, MonadParsecDbg e s m) => + MonadParsecDbg e s (S.RWST r w st m) + where + dbg str sma = S.RWST $ \r s -> do + let smth = + (\(a, st, w) -> ShowComment "LOG" (ShowComment "STATE" (a, st), w)) + <$> S.runRWST sma r s + ((a, st), w) <- first unComment . unComment <$> dbg str smth + pure (a, st, w) + +instance (MonadParsecDbg e s m) => MonadParsecDbg e s (IdentityT m) where + dbg = mapIdentityT . dbg + +-- | @'dbgWithComment' label_a label_c m@ traces the first component of the +-- result produced by @m@ with @label_a@ and the second component with +-- @label_b@. +dbgWithComment :: + (MonadParsecDbg e s m, Show a, Show c) => + -- | Debugging label (for @a@) + String -> + -- | Extra component label (for @c@) + String -> + -- | Parser to debug + m (a, c) -> + -- | Parser that prints debugging messages + m (a, c) +dbgWithComment lbl str ma = + unComment <$> dbg str (ShowComment lbl <$> ma) + +-- | A wrapper with a special show instance: +-- +-- >>> show (ShowComment "STATE" ("Hello, world!", 42)) +-- Hello, world! (STATE: 42) +data ShowComment c a = ShowComment String (a, c) + +unComment :: ShowComment c a -> (a, c) +unComment (ShowComment _ val) = val + +instance (Show c, Show a) => Show (ShowComment c a) where + show (ShowComment lbl (a, c)) = show a ++ " (" ++ lbl ++ ": " ++ show c ++ ")" + +instance + (VisualStream s, ShowErrorComponent e) => + MonadParsecDbg e s (ParsecT e s m) + where + dbg lbl p = ParsecT $ \s cok cerr eok eerr -> + let l = dbgLog lbl + unfold = streamTake 40 + cok' x s' hs = + flip trace (cok x s' hs) $ + l (DbgIn (unfold (stateInput s))) + ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x hs) + cerr' err s' = + flip trace (cerr err s') $ + l (DbgIn (unfold (stateInput s))) + ++ l (DbgCERR (streamTake (streamDelta s s') (stateInput s)) err) + eok' x s' hs = + flip trace (eok x s' hs) $ + l (DbgIn (unfold (stateInput s))) + ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x hs) + eerr' err s' = + flip trace (eerr err s') $ + l (DbgIn (unfold (stateInput s))) + ++ l (DbgEERR (streamTake (streamDelta s s') (stateInput s)) err) + in unParser p s cok' cerr' eok' eerr' + +-- | A single piece of info to be rendered with 'dbgLog'. data DbgItem s e a - = DbgIn [Token s] - | DbgCOK [Token s] a + = DbgIn [Token s] + | DbgCOK [Token s] a (Hints (Token s)) | DbgCERR [Token s] (ParseError s e) - | DbgEOK [Token s] a + | DbgEOK [Token s] a (Hints (Token s)) | DbgEERR [Token s] (ParseError s e) -- | Render a single piece of debugging info. - -dbgLog - :: forall s e a. (Stream s, ShowErrorComponent e, Show a) - => String -- ^ Debugging label - -> DbgItem s e a -- ^ Information to render - -> String -- ^ Rendered result +dbgLog :: + forall s e a. + (VisualStream s, ShowErrorComponent e, Show a) => + -- | Debugging label + String -> + -- | Information to render + DbgItem s e a -> + -- | Rendered result + String dbgLog lbl item = prefix msg where prefix = unlines . fmap ((lbl ++ "> ") ++) . lines pxy = Proxy :: Proxy s + showHints hs = "[" ++ List.intercalate "," (showErrorItem pxy <$> E.toAscList hs) ++ "]" msg = case item of - DbgIn ts -> + DbgIn ts -> "IN: " ++ showStream pxy ts - DbgCOK ts a -> - "MATCH (COK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a + DbgCOK ts a (Hints hs) -> + "MATCH (COK): " + ++ showStream pxy ts + ++ "\nVALUE: " + ++ show a + ++ "\nHINTS: " + ++ showHints hs DbgCERR ts e -> "MATCH (CERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e - DbgEOK ts a -> - "MATCH (EOK): " ++ showStream pxy ts ++ "\nVALUE: " ++ show a + DbgEOK ts a (Hints hs) -> + "MATCH (EOK): " + ++ showStream pxy ts + ++ "\nVALUE: " + ++ show a + ++ "\nHINTS: " + ++ showHints hs DbgEERR ts e -> "MATCH (EERR): " ++ showStream pxy ts ++ "\nERROR:\n" ++ parseErrorPretty e -- | Pretty-print a list of tokens. - -showStream :: Stream s => Proxy s -> [Token s] -> String +showStream :: (VisualStream s) => Proxy s -> [Token s] -> String showStream pxy ts = case NE.nonEmpty ts of Nothing -> "" Just ne -> let (h, r) = splitAt 40 (showTokens pxy ne) - in if null r then h else h ++ " <…>" + in if null r then h else h ++ " <…>" -- | Calculate number of consumed tokens given 'State' of parser before and -- after parsing. - -streamDelta - :: State s e -- ^ State of parser before consumption - -> State s e -- ^ State of parser after consumption - -> Int -- ^ Number of consumed tokens +streamDelta :: + -- | State of parser before consumption + State s e -> + -- | State of parser after consumption + State s e -> + -- | Number of consumed tokens + Int streamDelta s0 s1 = stateOffset s1 - stateOffset s0 -- | Extract a given number of tokens from the stream. - -streamTake :: forall s. Stream s => Int -> s -> [Token s] +streamTake :: forall s. (Stream s) => Int -> s -> [Token s] streamTake n s = case fst <$> takeN_ n s of Nothing -> [] Just chk -> chunkToTokens (Proxy :: Proxy s) chk + +-- | Just like 'dbg', but doesn't require the return value of the parser to +-- be 'Show'-able. +-- +-- @since 9.1.0 +dbg' :: + (MonadParsecDbg e s m) => + -- | Debugging label + String -> + -- | Parser to debug + m a -> + -- | Parser that prints debugging messages + m a +dbg' lbl p = unBlind <$> dbg lbl (Blind <$> p) + +-- | A wrapper type with a dummy 'Show' instance. +newtype Blind x = Blind {unBlind :: x} + +instance Show (Blind x) where + show _ = "NOT SHOWN" diff --git a/Text/Megaparsec/Error.hs b/Text/Megaparsec/Error.hs --- a/Text/Megaparsec/Error.hs +++ b/Text/Megaparsec/Error.hs @@ -1,3 +1,16 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Error -- Copyright : © 2015–present Megaparsec contributors @@ -7,95 +20,90 @@ -- Stability : experimental -- Portability : portable -- --- Parse errors. The current version of Megaparsec supports well-typed --- errors instead of 'String'-based ones. This gives a lot of flexibility in +-- Parse errors. The current version of Megaparsec supports 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. -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway. - -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec.Error ( -- * Parse error type - ErrorItem (..) - , ErrorFancy (..) - , ParseError (..) - , mapParseError - , errorOffset - , setErrorOffset - , ParseErrorBundle (..) - , attachSourcePos + ErrorItem (..), + ErrorFancy (..), + ParseError (..), + mapParseError, + errorOffset, + setErrorOffset, + ParseErrorBundle (..), + attachSourcePos, + -- * Pretty-printing - , ShowErrorComponent (..) - , errorBundlePretty - , parseErrorPretty - , parseErrorTextPretty ) + ShowErrorComponent (..), + errorBundlePretty, + errorBundlePrettyForGhcPreProcessors, + errorBundlePrettyWith, + parseErrorPretty, + parseErrorTextPretty, + showErrorItem, + ) where +import Control.Arrow ((>>>)) import Control.DeepSeq import Control.Exception import Control.Monad.State.Strict import Data.Data (Data) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe (isNothing) import Data.Proxy import Data.Set (Set) +import qualified Data.Set as E import Data.Typeable (Typeable) import Data.Void import GHC.Generics import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E +import qualified Text.Megaparsec.Unicode as Unicode ---------------------------------------------------------------------------- -- Parse error type --- | Data type that is used to represent “unexpected\/expected” items in --- 'ParseError'. The data type is parametrized over the token type @t@. +-- | A data type that is used to represent “unexpected\/expected” items in +-- 'ParseError'. It is parametrized over the token type @t@. -- -- @since 5.0.0 - 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, Generic, Functor) + = -- | Non-empty stream of tokens + Tokens (NonEmpty t) + | -- | Label (cannot be empty) + Label (NonEmpty Char) + | -- | End of input + EndOfInput + deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData t => NFData (ErrorItem t) +instance (NFData t) => NFData (ErrorItem t) -- | Additional error data, extendable by user. When no custom data is -- necessary, the type is typically indexed by 'Void' to “cancel” the -- 'ErrorCustom' constructor. -- -- @since 6.0.0 - data ErrorFancy e - = ErrorFail String - -- ^ 'fail' has been used in parser monad - | ErrorIndentation Ordering Pos Pos - -- ^ Incorrect indentation error: desired ordering between reference + = -- | 'fail' has been used in parser monad + ErrorFail String + | -- | Incorrect indentation error: desired ordering between reference -- level and actual level, reference indentation level, actual -- indentation level - | ErrorCustom e - -- ^ Custom error data - deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor) + ErrorIndentation Ordering Pos Pos + | -- | Custom error data + ErrorCustom e + deriving (Show, Read, Eq, Ord, Data, Generic, Functor) -instance NFData a => NFData (ErrorFancy a) where +instance (NFData a) => NFData (ErrorFancy a) where rnf (ErrorFail str) = rnf str rnf (ErrorIndentation ord ref act) = ord `seq` rnf ref `seq` rnf act rnf (ErrorCustom a) = rnf a @@ -103,89 +111,96 @@ -- | @'ParseError' s e@ represents a parse error parametrized over the -- stream type @s@ and the custom data @e@. -- --- 'Semigroup' and 'Monoid' instances of the data type allow to merge parse --- errors from different branches of parsing. When merging two +-- 'Semigroup' and 'Monoid' instances of the data type allow us to merge +-- parse errors from different branches of parsing. When merging two -- 'ParseError's, the longest match is preferred; if positions are the same, -- custom data sets and collections of message items are combined. Note that -- fancy errors take precedence over trivial errors in merging. -- -- @since 7.0.0 - data ParseError s e - = TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) - -- ^ Trivial errors, generated by Megaparsec's machinery. The data + = -- | Trivial errors, generated by the Megaparsec's machinery. The data -- constructor includes the offset of error, unexpected token (if any), -- and expected tokens. -- -- Type of the first argument was changed in the version /7.0.0/. - | FancyError Int (Set (ErrorFancy e)) - -- ^ Fancy, custom errors. + TrivialError Int (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) + | -- | Fancy, custom errors. -- -- Type of the first argument was changed in the version /7.0.0/. - deriving (Typeable, Generic) + FancyError Int (Set (ErrorFancy e)) + deriving (Generic) -deriving instance ( Show (Token s) - , Show e - ) => Show (ParseError s e) +deriving instance + ( Show (Token s), + Show e + ) => + Show (ParseError s e) -deriving instance ( Eq (Token s) - , Eq e - ) => Eq (ParseError s e) +deriving instance + ( Eq (Token s), + Eq e + ) => + Eq (ParseError s e) -deriving instance ( Data s - , Data (Token s) - , Ord (Token s) - , Data e - , Ord e - ) => Data (ParseError s e) +deriving instance + ( Data s, + Data (Token s), + Ord (Token s), + Data e, + Ord e + ) => + Data (ParseError s e) -instance ( NFData (Token s) - , NFData e - ) => NFData (ParseError s e) +instance + ( NFData (Token s), + NFData e + ) => + NFData (ParseError s e) instance (Stream s, Ord e) => Semigroup (ParseError s e) where (<>) = mergeError {-# INLINE (<>) #-} instance (Stream s, Ord e) => Monoid (ParseError s e) where - mempty = TrivialError 0 Nothing E.empty + mempty = TrivialError 0 Nothing E.empty mappend = (<>) {-# INLINE mappend #-} -instance ( Show s - , Show (Token s) - , Show e - , ShowErrorComponent e - , Stream s - , Typeable s - , Typeable e ) - => Exception (ParseError s e) where +instance + ( Show (Token s), + Show e, + ShowErrorComponent e, + VisualStream s, + Typeable s, + Typeable e + ) => + Exception (ParseError s e) + where displayException = parseErrorPretty -- | Modify the custom data component in a parse error. This could be done -- via 'fmap' if not for the 'Ord' constraint. -- -- @since 7.0.0 - -mapParseError :: Ord e' - => (e -> e') - -> ParseError s e - -> ParseError s e' +mapParseError :: + (Ord e') => + (e -> e') -> + ParseError s e -> + ParseError s e' mapParseError _ (TrivialError o u p) = TrivialError o u p mapParseError f (FancyError o x) = FancyError o (E.map (fmap f) x) --- | Get offset of 'ParseError'. +-- | Get the offset of a 'ParseError'. -- -- @since 7.0.0 - errorOffset :: ParseError s e -> Int errorOffset (TrivialError o _ _) = o -errorOffset (FancyError o _) = o +errorOffset (FancyError o _) = o --- | Set offset of 'ParseError'. +-- | Set the offset of a 'ParseError'. -- -- @since 8.0.0 - setErrorOffset :: Int -> ParseError s e -> ParseError s e setErrorOffset o (TrivialError _ u p) = TrivialError o u p setErrorOffset o (FancyError _ x) = FancyError o x @@ -195,11 +210,11 @@ -- 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. - -mergeError :: (Stream s, Ord e) - => ParseError s e - -> ParseError s e - -> ParseError s e +mergeError :: + (Stream s, Ord e) => + ParseError s e -> + ParseError s e -> + ParseError s e mergeError e1 e2 = case errorOffset e1 `compare` errorOffset e2 of LT -> e2 @@ -221,75 +236,84 @@ -- arbitrary, but is necessary because otherwise we can't make -- ParseError lawful Monoid and have nice parse errors at the same -- time). - n Nothing Nothing = Nothing + n Nothing Nothing = Nothing n (Just x) Nothing = Just x n Nothing (Just y) = Just y n (Just x) (Just y) = Just (max x y) {-# INLINE mergeError #-} -- | A non-empty collection of 'ParseError's equipped with 'PosState' that --- allows to pretty-print the errors efficiently and correctly. +-- allows us to pretty-print the errors efficiently and correctly. -- -- @since 7.0.0 - data ParseErrorBundle s e = ParseErrorBundle - { bundleErrors :: NonEmpty (ParseError s e) - -- ^ A collection of 'ParseError's that is sorted by parse error offsets - , bundlePosState :: PosState s - -- ^ State that is used for line\/column calculation - } deriving (Generic) - -deriving instance ( Show s - , Show (Token s) - , Show e - ) => Show (ParseErrorBundle s e) + { -- | A collection of 'ParseError's that is sorted by parse error offsets + bundleErrors :: NonEmpty (ParseError s e), + -- | The state that is used for line\/column calculation + bundlePosState :: PosState s + } + deriving (Generic) -deriving instance ( Eq s - , Eq (Token s) - , Eq e - ) => Eq (ParseErrorBundle s e) +deriving instance + ( Show s, + Show (Token s), + Show e + ) => + Show (ParseErrorBundle s e) -deriving instance ( Typeable s - , Typeable (Token s) - , Typeable e - ) => Typeable (ParseErrorBundle s e) +deriving instance + ( Eq s, + Eq (Token s), + Eq e + ) => + Eq (ParseErrorBundle s e) -deriving instance ( Data s - , Data (Token s) - , Ord (Token s) - , Data e - , Ord e - ) => Data (ParseErrorBundle s e) +deriving instance + ( Data s, + Data (Token s), + Ord (Token s), + Data e, + Ord e + ) => + Data (ParseErrorBundle s e) -instance ( NFData s - , NFData (Token s) - , NFData e - ) => NFData (ParseErrorBundle s e) +instance + ( NFData s, + NFData (Token s), + NFData e + ) => + NFData (ParseErrorBundle s e) -instance ( Show s - , Show (Token s) - , Show e - , ShowErrorComponent e - , Stream s - , Typeable s - , Typeable e - ) => Exception (ParseErrorBundle s e) where +instance + ( Show s, + Show (Token s), + Show e, + ShowErrorComponent e, + VisualStream s, + TraversableStream s, + Typeable s, + Typeable e + ) => + Exception (ParseErrorBundle s e) + where displayException = errorBundlePretty -- | Attach 'SourcePos'es to items in a 'Traversable' container given that --- there is a projection allowing to get an offset per item. +-- there is a projection allowing us to get an offset per item. -- -- Items must be in ascending order with respect to their offsets. -- -- @since 7.0.0 - -attachSourcePos - :: (Traversable t, Stream s) - => (a -> Int) -- ^ How to project offset from an item (e.g. 'errorOffset') - -> t a -- ^ The collection of items - -> PosState s -- ^ Initial 'PosState' - -> (t (a, SourcePos), PosState s) -- ^ The collection with 'SourcePos'es - -- added and the final 'PosState' +attachSourcePos :: + (Traversable t, TraversableStream s) => + -- | How to project offset from an item (e.g. 'errorOffset') + (a -> Int) -> + -- | The collection of items + t a -> + -- | Initial 'PosState' + PosState s -> + -- | The collection with 'SourcePos'es added and the final 'PosState' + (t (a, SourcePos), PosState s) attachSourcePos projectOffset xs = runState (traverse f xs) where f a = do @@ -305,18 +329,14 @@ -- | The type class defines how to print a custom component of 'ParseError'. -- -- @since 5.0.0 - -class Ord a => ShowErrorComponent a where - +class (Ord a) => ShowErrorComponent a where -- | Pretty-print a component of 'ParseError'. - showErrorComponent :: a -> String -- | Length of the error component in characters, used for highlighting of -- parse errors in input string. -- -- @since 7.0.0 - errorComponentLen :: a -> Int errorComponentLen _ = 1 @@ -324,48 +344,94 @@ showErrorComponent = absurd -- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will --- be pretty-printed in order together with the corresponding offending --- lines by doing a single efficient pass over the input stream. The --- rendered 'String' always ends with a newline. +-- be pretty-printed in order, by applying a provided format function, with +-- a single pass over the input stream. -- --- @since 7.0.0 - -errorBundlePretty - :: forall s e. ( Stream s - , ShowErrorComponent e - ) - => ParseErrorBundle s e -- ^ Parse error bundle to display - -> String -- ^ Textual rendition of the bundle -errorBundlePretty ParseErrorBundle {..} = +-- @since 9.7.0 +errorBundlePrettyWith :: + forall s e. + ( VisualStream s, + TraversableStream s + ) => + -- | Format function for a single 'ParseError' + (Maybe String -> SourcePos -> ParseError s e -> String) -> + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePrettyWith format ParseErrorBundle {..} = let (r, _) = foldl f (id, bundlePosState) bundleErrors - in drop 1 (r "") + in r "" where - f :: (ShowS, PosState s) - -> ParseError s e - -> (ShowS, PosState s) + f :: + (ShowS, PosState s) -> + ParseError s e -> + (ShowS, PosState s) f (o, !pst) e = (o . (outChunk ++), pst') where - (sline, pst') = reachOffset (errorOffset e) pst + (msline, pst') = reachOffset (errorOffset e) pst epos = pstateSourcePos pst' + outChunk = format msline epos e + +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order together with the corresponding offending +-- lines by doing a single pass over the input stream. The rendered 'String' +-- always ends with a newline. +-- +-- @since 7.0.0 +errorBundlePretty :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePretty = drop 1 . errorBundlePrettyWith format + where + format :: + Maybe String -> + SourcePos -> + ParseError s e -> + String + format msline epos e = outChunk + where outChunk = - "\n" <> sourcePosPretty epos <> ":\n" <> - padding <> "|\n" <> - lineNumber <> " | " <> sline <> "\n" <> - padding <> "| " <> rpadding <> pointer <> "\n" <> - parseErrorTextPretty e - lineNumber = (show . unPos . sourceLine) epos - padding = replicate (length lineNumber + 1) ' ' - rpadding = - if pointerLen > 0 - then replicate rpshift ' ' - else "" - rpshift = unPos (sourceColumn epos) - 1 - pointer = replicate pointerLen '^' - pointerLen = - if rpshift + elen > slineLen - then slineLen - rpshift + 1 - else elen - slineLen = length sline + "\n" + <> sourcePosPretty epos + <> ":\n" + <> offendingLine + <> parseErrorTextPretty e + offendingLine = + case msline of + Nothing -> "" + Just sline -> + let rpadding = + if pointerLen > 0 + then replicate rpshift ' ' + else "" + pointerLen = + if rpshift + elen > slineLen + then slineLen - rpshift + 1 + else max 1 elen + pointer = replicate pointerLen '^' + lineNumber = (show . unPos . sourceLine) epos + padding = replicate (length lineNumber + 1) ' ' + rpshift = unPos (sourceColumn epos) - 1 + slineLen = Unicode.stringLength sline + in padding + <> "|\n" + <> lineNumber + <> " | " + <> sline + <> "\n" + <> padding + <> "| " + <> rpadding + <> pointer + <> "\n" pxy = Proxy :: Proxy s elen = case e of @@ -374,15 +440,51 @@ FancyError _ xs -> E.foldl' (\a b -> max a (errorFancyLength b)) 1 xs +-- | Pretty-print a 'ParseErrorBundle'. All 'ParseError's in the bundle will +-- be pretty-printed in order by doing a single pass over the input stream. +-- +-- The rendered format is suitable for custom GHC pre-processors (as can be +-- specified with -F -pgmF). +-- +-- @since 9.7.0 +errorBundlePrettyForGhcPreProcessors :: + forall s e. + ( VisualStream s, + TraversableStream s, + ShowErrorComponent e + ) => + -- | Parse error bundle to display + ParseErrorBundle s e -> + -- | Textual rendition of the bundle + String +errorBundlePrettyForGhcPreProcessors = errorBundlePrettyWith format + where + format :: + Maybe String -> + SourcePos -> + ParseError s e -> + String + format _msline epos e = + sourcePosPretty epos + <> ":" + <> indent (parseErrorTextPretty e) + + indent :: String -> String + indent = + lines >>> \case + [err] -> err + err -> intercalate "\n" $ map (" " <>) err + -- | Pretty-print a 'ParseError'. The rendered 'String' always ends with a -- newline. -- -- @since 5.0.0 - -parseErrorPretty - :: (Stream s, ShowErrorComponent e) - => ParseError s e -- ^ Parse error to render - -> String -- ^ Result of rendering +parseErrorPretty :: + (VisualStream s, ShowErrorComponent e) => + -- | Parse error to render + ParseError s e -> + -- | Result of rendering + String parseErrorPretty e = "offset=" <> show (errorOffset e) <> ":\n" <> parseErrorTextPretty e @@ -391,16 +493,19 @@ -- newline. -- -- @since 5.1.0 - -parseErrorTextPretty - :: forall s e. (Stream s, ShowErrorComponent e) - => ParseError s e -- ^ Parse error to render - -> String -- ^ Result of rendering +parseErrorTextPretty :: + forall s e. + (VisualStream s, ShowErrorComponent e) => + -- | Parse error to render + ParseError s e -> + -- | Result of rendering + String parseErrorTextPretty (TrivialError _ us ps) = if isNothing us && E.null ps then "unknown parse error\n" - else messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us) <> - messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps) + else + messageItemsPretty "unexpected " (showErrorItem pxy `E.map` maybe E.empty E.singleton us) + <> messageItemsPretty "expecting " (showErrorItem pxy `E.map` ps) where pxy = Proxy :: Proxy s parseErrorTextPretty (FancyError _ xs) = @@ -412,57 +517,60 @@ -- Helpers -- | Pretty-print an 'ErrorItem'. - -showErrorItem :: Stream s => Proxy s -> ErrorItem (Token s) -> String +-- +-- @since 9.4.0 +showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String showErrorItem pxy = \case - Tokens ts -> showTokens pxy ts - Label label -> NE.toList label - EndOfInput -> "end of input" + Tokens ts -> showTokens pxy ts + Label label -> NE.toList label + EndOfInput -> "end of input" -- | Get length of the “pointer” to display under a given 'ErrorItem'. - -errorItemLength :: Stream s => Proxy s -> ErrorItem (Token s) -> Int +errorItemLength :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> Int errorItemLength pxy = \case Tokens ts -> tokensLength pxy ts - _ -> 1 + _ -> 1 -- | Pretty-print an 'ErrorFancy'. - -showErrorFancy :: ShowErrorComponent e => ErrorFancy e -> String +showErrorFancy :: (ShowErrorComponent e) => ErrorFancy e -> String showErrorFancy = \case ErrorFail msg -> msg ErrorIndentation ord ref actual -> - "incorrect indentation (got " <> show (unPos actual) <> - ", should be " <> p <> show (unPos ref) <> ")" + "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 " + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " ErrorCustom a -> showErrorComponent a -- | Get length of the “pointer” to display under a given 'ErrorFancy'. - -errorFancyLength :: ShowErrorComponent e => ErrorFancy e -> Int +errorFancyLength :: (ShowErrorComponent e) => ErrorFancy e -> Int errorFancyLength = \case ErrorCustom a -> errorComponentLen a - _ -> 1 - --- | Transforms a list of error messages into their textual representation. + _ -> 1 -messageItemsPretty - :: String -- ^ Prefix to prepend - -> Set String -- ^ Collection of messages - -> String -- ^ Result of rendering +-- | Transform a list of error messages into their textual representation. +messageItemsPretty :: + -- | Prefix to prepend + String -> + -- | Collection of messages + Set String -> + -- | Result of rendering + String messageItemsPretty prefix ts | E.null ts = "" | otherwise = - prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n" + prefix <> (orList . NE.fromList . E.toAscList) ts <> "\n" -- | Print a pretty list where items are separated with commas and the word -- “or” according to the rules of English punctuation. - orList :: NonEmpty String -> String -orList (x:|[]) = x -orList (x:|[y]) = x <> " or " <> y -orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs +orList (x :| []) = x +orList (x :| [y]) = x <> " or " <> y +orList xs = intercalate ", " (NE.init xs) <> ", or " <> NE.last xs diff --git a/Text/Megaparsec/Error.hs-boot b/Text/Megaparsec/Error.hs-boot --- a/Text/Megaparsec/Error.hs-boot +++ b/Text/Megaparsec/Error.hs-boot @@ -1,7 +1,8 @@ {-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE Safe #-} module Text.Megaparsec.Error - ( ParseError + ( ParseError, ) where diff --git a/Text/Megaparsec/Error/Builder.hs b/Text/Megaparsec/Error/Builder.hs --- a/Text/Megaparsec/Error/Builder.hs +++ b/Text/Megaparsec/Error/Builder.hs @@ -1,3 +1,11 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Error.Builder -- Copyright : © 2015–present Megaparsec contributors @@ -11,189 +19,174 @@ -- concise. This is primarily useful in test suites and for debugging. -- -- @since 6.0.0 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec.Error.Builder ( -- * Top-level helpers - err - , errFancy + err, + errFancy, + -- * Error components - , utok - , utoks - , ulabel - , ueof - , etok - , etoks - , elabel - , eeof - , fancy + utok, + utoks, + ulabel, + ueof, + etok, + etoks, + elabel, + eeof, + fancy, + -- * Data types - , ET - , EF ) + ET, + EF, + ) where import Data.Data (Data) import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Set (Set) -import Data.Typeable (Typeable) +import qualified Data.Set as E import GHC.Generics import Text.Megaparsec.Error import Text.Megaparsec.Stream -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E ---------------------------------------------------------------------------- -- Data types -- | Auxiliary type for construction of trivial parse errors. - data ET s = ET (Maybe (ErrorItem (Token s))) (Set (ErrorItem (Token s))) - deriving (Typeable, Generic) + deriving (Generic) -deriving instance Eq (Token s) => Eq (ET s) +deriving instance (Eq (Token s)) => Eq (ET s) -deriving instance Ord (Token s) => Ord (ET s) +deriving instance (Ord (Token s)) => Ord (ET s) -deriving instance ( Data s - , Data (Token s) - , Ord (Token s) - ) => Data (ET s) +deriving instance + ( Data s, + Data (Token s), + Ord (Token s) + ) => + Data (ET s) -instance Stream s => Semigroup (ET s) where +instance (Stream s) => Semigroup (ET s) where ET us0 ps0 <> ET us1 ps1 = ET (n us0 us1) (E.union ps0 ps1) where - n Nothing Nothing = Nothing + n Nothing Nothing = Nothing n (Just x) Nothing = Just x n Nothing (Just y) = Just y n (Just x) (Just y) = Just (max x y) -instance Stream s => Monoid (ET s) where - mempty = ET Nothing E.empty +instance (Stream s) => Monoid (ET s) where + mempty = ET Nothing E.empty mappend = (<>) -- | Auxiliary type for construction of fancy parse errors. - newtype EF e = EF (Set (ErrorFancy e)) - deriving (Eq, Ord, Data, Typeable, Generic) + deriving (Eq, Ord, Data, Generic) -instance Ord e => Semigroup (EF e) where +instance (Ord e) => Semigroup (EF e) where EF xs0 <> EF xs1 = EF (E.union xs0 xs1) -instance Ord e => Monoid (EF e) where - mempty = EF E.empty +instance (Ord e) => Monoid (EF e) where + mempty = EF E.empty mappend = (<>) ---------------------------------------------------------------------------- -- Top-level helpers --- | Assemble a 'ParseError' from offset and @'ET' t@ value. @'ET' t@ is a --- monoid and can be assembled by combining primitives provided by this --- module, see below. - -err - :: Int -- ^ 'ParseError' offset - -> ET s -- ^ Error components - -> ParseError s e -- ^ Resulting 'ParseError' +-- | Assemble a 'ParseError' from the offset and the @'ET' t@ value. @'ET' +-- t@ is a monoid and can be assembled by combining primitives provided by +-- this module, see below. +err :: + -- | 'ParseError' offset + Int -> + -- | Error components + ET s -> + -- | Resulting 'ParseError' + ParseError s e err p (ET us ps) = TrivialError p us ps -- | Like 'err', but constructs a “fancy” 'ParseError'. - -errFancy - :: Int -- ^ 'ParseError' offset - -> EF e -- ^ Error components - -> ParseError s e -- ^ Resulting 'ParseError' +errFancy :: + -- | 'ParseError' offset + Int -> + -- | Error components + EF e -> + -- | Resulting 'ParseError' + ParseError s e errFancy p (EF xs) = FancyError p xs ---------------------------------------------------------------------------- -- Error components -- | Construct an “unexpected token” error component. - -utok :: Stream s => Token s -> ET s +utok :: Token s -> ET s utok = unexp . Tokens . nes -- | Construct an “unexpected tokens” error component. Empty chunk produces -- 'EndOfInput'. - -utoks :: forall s. Stream s => Tokens s -> ET s +utoks :: forall s. (Stream s) => Tokens s -> ET s utoks = unexp . canonicalizeTokens (Proxy :: Proxy s) -- | Construct an “unexpected label” error component. Do not use with empty -- strings (for empty strings it's bottom). - -ulabel :: Stream s => String -> ET s +ulabel :: String -> ET s ulabel label | label == "" = error "Text.Megaparsec.Error.Builder.ulabel: empty label" | otherwise = unexp . Label . NE.fromList $ label -- | Construct an “unexpected end of input” error component. - -ueof :: Stream s => ET s +ueof :: ET s ueof = unexp EndOfInput -- | Construct an “expected token” error component. - -etok :: Stream s => Token s -> ET s +etok :: Token s -> ET s etok = expe . Tokens . nes -- | Construct an “expected tokens” error component. Empty chunk produces -- 'EndOfInput'. - -etoks :: forall s. Stream s => Tokens s -> ET s +etoks :: forall s. (Stream s) => Tokens s -> ET s etoks = expe . canonicalizeTokens (Proxy :: Proxy s) -- | Construct an “expected label” error component. Do not use with empty -- strings. - -elabel :: Stream s => String -> ET s +elabel :: String -> ET s elabel label | label == "" = error "Text.Megaparsec.Error.Builder.elabel: empty label" | otherwise = expe . Label . NE.fromList $ label -- | Construct an “expected end of input” error component. - -eeof :: Stream s => ET s +eeof :: ET s eeof = expe EndOfInput -- | Construct a custom error component. - fancy :: ErrorFancy e -> EF e fancy = EF . E.singleton ---------------------------------------------------------------------------- -- Helpers --- | Construct appropriate 'ErrorItem' representation for given token --- stream. Empty string produces 'EndOfInput'. - -canonicalizeTokens - :: Stream s - => Proxy s - -> Tokens s - -> ErrorItem (Token s) +-- | Construct the appropriate 'ErrorItem' representation for the given +-- token stream. The empty string produces 'EndOfInput'. +canonicalizeTokens :: + (Stream s) => + Proxy s -> + Tokens s -> + ErrorItem (Token s) canonicalizeTokens pxy ts = case NE.nonEmpty (chunkToTokens pxy ts) of Nothing -> EndOfInput Just xs -> Tokens xs -- | Lift an unexpected item into 'ET'. - -unexp :: Stream s => ErrorItem (Token s) -> ET s +unexp :: ErrorItem (Token s) -> ET s unexp u = ET (pure u) E.empty -- | Lift an expected item into 'ET'. - -expe :: Stream s => ErrorItem (Token s) -> ET s +expe :: ErrorItem (Token s) -> ET s expe p = ET Nothing (E.singleton p) -- | Make a singleton non-empty list from a value. - nes :: a -> NonEmpty a nes x = x :| [] diff --git a/Text/Megaparsec/Internal.hs b/Text/Megaparsec/Internal.hs --- a/Text/Megaparsec/Internal.hs +++ b/Text/Megaparsec/Internal.hs @@ -1,3 +1,16 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Internal -- Copyright : © 2015–present Megaparsec contributors @@ -13,55 +26,47 @@ -- rely on these unless you really know what you're doing. -- -- @since 6.5.0 - -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec.Internal ( -- * Data types - Hints (..) - , Reply (..) - , Consumption (..) - , Result (..) - , ParsecT (..) + Hints (..), + Reply (..), + Consumption (..), + Result (..), + ParsecT (..), + -- * Helper functions - , toHints - , withHints - , accHints - , refreshLastHint - , runParsecT - , withParsecT ) + toHints, + withHints, + accHints, + refreshHints, + runParsecT, + withParsecT, + ) where import Control.Applicative import Control.Monad +import qualified Control.Monad.Combinators import Control.Monad.Cont.Class import Control.Monad.Error.Class +import qualified Control.Monad.Fail as Fail import Control.Monad.Fix import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans +import Control.Monad.Writer.Class import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Proxy import Data.Semigroup import Data.Set (Set) +import qualified Data.Set as E import Data.String (IsString (..)) import Text.Megaparsec.Class import Text.Megaparsec.Error import Text.Megaparsec.State import Text.Megaparsec.Stream -import qualified Control.Monad.Fail as Fail -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E ---------------------------------------------------------------------------- -- Data types @@ -84,49 +89,57 @@ -- 1:2: -- unexpected 'a' -- expecting 'r' or end of input +newtype Hints t = Hints (Set (ErrorItem t)) -newtype Hints t = Hints [Set (ErrorItem t)] - deriving (Semigroup, Monoid) +instance (Ord t) => Semigroup (Hints t) where + Hints xs <> Hints ys = Hints $ xs <> ys +instance (Ord t) => Monoid (Hints t) where + mempty = Hints mempty + -- | All information available after parsing. This includes consumption of --- input, success (with returned value) or failure (with parse error), and --- parser state at the end of parsing. +-- input, success (with the returned value) or failure (with the parse +-- error), and parser state at the end of parsing. 'Reply' can also be used +-- to resume parsing. -- -- See also: 'Consumption', 'Result'. - data Reply e s a = Reply (State s e) Consumption (Result s e a) + deriving (Functor) -- | Whether the input has been consumed or not. -- -- See also: 'Result', 'Reply'. - data Consumption - = Consumed -- ^ Some part of input stream was consumed - | Virgin -- ^ No input was consumed + = -- | Some part of input stream was consumed + Consumed + | -- | No input was consumed + NotConsumed -- | Whether the parser has failed or not. On success we include the -- resulting value, on failure we include a 'ParseError'. -- -- See also: 'Consumption', 'Reply'. - data Result s e a - = OK a -- ^ Parser succeeded - | Error (ParseError s e) -- ^ Parser failed + = -- | Parser succeeded (includes hints) + OK (Hints (Token s)) a + | -- | Parser failed + Error (ParseError s e) + deriving (Functor) -- | @'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 e s m a = ParsecT - { unParser - :: forall b. State s e - -> (a -> State s e -> Hints (Token s) -> m b) -- consumed-OK - -> (ParseError s e -> State s e -> m b) -- consumed-error - -> (a -> State s e -> Hints (Token s) -> m b) -- empty-OK - -> (ParseError s e -> State s e -> m b) -- empty-error - -> m b } + { unParser :: + forall b. + State s e -> + (a -> State s e -> Hints (Token s) -> m b) -> -- consumed-OK + (ParseError s e -> State s e -> m b) -> -- consumed-error + (a -> State s e -> Hints (Token s) -> m b) -> -- empty-OK + (ParseError s e -> State s e -> m b) -> -- empty-error + m b + } -- | @since 5.3.0 - instance (Stream s, Semigroup a) => Semigroup (ParsecT e s m a) where (<>) = liftA2 (<>) {-# INLINE (<>) #-} @@ -134,7 +147,6 @@ {-# INLINE sconcat #-} -- | @since 5.3.0 - instance (Stream s, Monoid a) => Monoid (ParsecT e s m a) where mempty = pure mempty {-# INLINE mempty #-} @@ -144,9 +156,10 @@ {-# INLINE mconcat #-} -- | @since 6.3.0 - -instance (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) - => IsString (ParsecT e s m a) where +instance + (a ~ Tokens s, IsString a, Eq a, Stream s, Ord e) => + IsString (ParsecT e s m a) + where fromString s = tokens (==) (fromString s) instance Functor (ParsecT e s m) where @@ -158,103 +171,174 @@ {-# INLINE pMap #-} -- | 'pure' returns a parser that __succeeds__ without consuming input. - -instance Stream s => Applicative (ParsecT e s m) where - pure = pPure - (<*>) = pAp +instance (Stream s) => Applicative (ParsecT e s m) where + pure = pPure + (<*>) = pAp p1 *> p2 = p1 `pBind` const p2 - p1 <* p2 = do { x1 <- p1 ; void p2 ; return x1 } + {-# INLINE (*>) #-} + p1 <* p2 = do x1 <- p1; void p2; return x1 + {-# INLINE (<*) #-} -pPure :: a -> ParsecT e s m a +pPure :: (Stream s) => a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty {-# INLINE pPure #-} -pAp :: Stream s - => ParsecT e s m (a -> b) - -> ParsecT e s m a - -> ParsecT e s m b +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 + 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 #-} -- | 'empty' is a parser that __fails__ without consuming input. - instance (Ord e, Stream s) => Alternative (ParsecT e s m) where - empty = mzero - (<|>) = mplus + empty = mzero + (<|>) = mplus + many = Control.Monad.Combinators.many + some = Control.Monad.Combinators.some -- | 'return' returns a parser that __succeeds__ without consuming input. - -instance Stream s => Monad (ParsecT e s m) where +instance (Stream s) => Monad (ParsecT e s m) where return = pure - (>>=) = pBind -#if !(MIN_VERSION_base(4,13,0)) - fail = Fail.fail -#endif + (>>=) = pBind -pBind :: Stream s - => ParsecT e s m a - -> (a -> ParsecT e s m b) - -> ParsecT e 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) - meok x s' hs = unParser (k x) s' cok cerr - (accHints hs eok) (withHints hs eerr) - in unParser m s mcok cerr meok eerr + let mcok x s' hs = + unParser + (k x) + s' + cok + cerr + (accHints hs cok) + (withHints hs cerr) + meok x s' hs = + unParser + (k x) + s' + cok + cerr + (accHints hs eok) + (withHints hs eerr) + in unParser m s mcok cerr meok eerr {-# INLINE pBind #-} -instance Stream s => Fail.MonadFail (ParsecT e s m) where +instance (Stream s) => Fail.MonadFail (ParsecT e s m) where fail = pFail pFail :: String -> ParsecT e s m a pFail msg = ParsecT $ \s@(State _ o _ _) _ _ _ eerr -> let d = E.singleton (ErrorFail msg) - in eerr (FancyError o d) s + in eerr (FancyError o d) s {-# INLINE pFail #-} instance (Stream s, MonadIO m) => MonadIO (ParsecT e s m) where liftIO = lift . liftIO instance (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) + ask = lift ask + local f = hoistP (local f) instance (Stream s, MonadState st m) => MonadState st (ParsecT e s m) where get = lift get put = lift . put +hoistP :: + (Monad m) => + (m (Reply e s a) -> m (Reply e s b)) -> + ParsecT e s m a -> + ParsecT e s m b +hoistP h p = mkParsecT (h . runParsecT p) + +-- | @since 9.5.0 +instance (Stream s, MonadWriter w m) => MonadWriter w (ParsecT e s m) where + tell w = lift (tell w) + listen = hoistP (fmap (\(repl, w) -> fmap (,w) repl) . listen) + pass = hoistP $ \m -> pass $ do + Reply st consumption r <- m + let (r', ww') = case r of + OK hs (x, ww) -> (OK hs x, ww) + Error e -> (Error e, id) + return (Reply st consumption r', ww') + instance (Stream s, MonadCont m) => MonadCont (ParsecT e s m) where - callCC f = mkPT $ \s -> + callCC f = mkParsecT $ \s -> callCC $ \c -> - runParsecT (f (\a -> mkPT $ \s' -> c (pack s' a))) s - where pack s a = Reply s Virgin (OK a) + runParsecT (f (\a -> mkParsecT $ \s' -> c (pack s' a))) s + where + pack s a = Reply s NotConsumed (OK mempty a) instance (Stream s, MonadError e' m) => MonadError e' (ParsecT e s m) where throwError = lift . throwError - p `catchError` h = mkPT $ \s -> + p `catchError` h = mkParsecT $ \s -> runParsecT p s `catchError` \e -> runParsecT (h e) s -mkPT :: Monad m => (State s e -> m (Reply e s a)) -> ParsecT e s m a -mkPT k = ParsecT $ \s cok cerr eok eerr -> do +mkParsecT :: + (Monad m) => + (State s e -> m (Reply e s a)) -> + ParsecT e s m a +mkParsecT k = ParsecT $ \s cok cerr eok eerr -> do (Reply s' consumption result) <- k s case consumption of Consumed -> case result of - OK x -> cok x s' mempty + OK hs x -> cok x s' hs Error e -> cerr e s' - Virgin -> + NotConsumed -> case result of - OK x -> eok x s' mempty + OK hs x -> eok x s' hs Error e -> eerr e s' +{-# INLINE mkParsecT #-} --- | 'mzero' is a parser that __fails__ without consuming input. +pmkParsec :: + (State s e -> Reply e s a) -> + ParsecT e s m a +pmkParsec k = ParsecT $ \s cok cerr eok eerr -> + let (Reply s' consumption result) = k s + in case consumption of + Consumed -> + case result of + OK hs x -> cok x s' hs + Error e -> cerr e s' + NotConsumed -> + case result of + OK hs x -> eok x s' hs + Error e -> eerr e s' +{-# INLINE pmkParsec #-} +-- | 'mzero' is a parser that __fails__ without consuming input. +-- +-- __Note__: strictly speaking, this instance is unlawful. The right +-- identity law does not hold, e.g. in general this is not true: +-- +-- > v >> mzero = mzero +-- +-- However the following holds: +-- +-- > try v >> mzero = mzero instance (Ord e, Stream s) => MonadPlus (ParsecT e s m) where mzero = pZero mplus = pPlus @@ -264,23 +348,46 @@ eerr (TrivialError o Nothing E.empty) s {-# INLINE pZero #-} -pPlus :: (Ord e, Stream s) - => ParsecT e s m a - -> ParsecT e s m a - -> ParsecT e s m a +pPlus :: + (Ord 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') - neok x s' hs = eok x s' (toHints (stateOffset s') err <> hs) - neerr err' s' = eerr (err' <> err) (longestMatch ms s') - in unParser n s cok ncerr neok neerr - in unParser m s cok cerr eok meerr + neok x s' hs = eok x s' (toHints (stateOffset s') err <> hs) + neerr err' s' = + let combinedErr = combineErrors (stateOffset s) err err' + in eerr combinedErr (longestMatch ms s') + in unParser n s cok ncerr neok neerr + in unParser m s cok cerr eok meerr + where + combineErrors altOffset e1 e2 = case (e1, e2) of + (TrivialError o1 u1 p1, TrivialError o2 u2 p2) -> + -- When merging alternative errors, if one is ahead due to try, we + -- bring both to the alternative position and union their expected + -- tokens. + if o1 > altOffset || o2 > altOffset + then + -- At least one error is ahead, normalize to alt position. Only + -- include expected tokens from errors at the alt position. + let p1' = if o1 == altOffset then p1 else E.empty + p2' = if o2 == altOffset then p2 else E.empty + -- Use the unexpected from the error at alt position, or the + -- furthest. + unexp = case (o1 `compare` altOffset, o2 `compare` altOffset) of + (EQ, _) -> u1 + (_, EQ) -> u2 + _ -> if o1 >= o2 then u1 else u2 + in TrivialError altOffset unexp (E.union p1' p2') + else e2 <> e1 + _ -> e2 <> e1 {-# INLINE pPlus #-} -- | From two states, return the one with the greater number of processed -- tokens. If the numbers of processed tokens are equal, prefer the second -- state. - longestMatch :: State s e -> State s e -> State s e longestMatch s1@(State _ o1 _ _) s2@(State _ o2 _ _) = case o1 `compare` o2 of @@ -290,39 +397,38 @@ {-# INLINE longestMatch #-} -- | @since 6.0.0 - instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where - mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do - let - a = case result of - OK a' -> a' - Error _ -> error "mfix ParsecT" + mfix f = mkParsecT $ \s -> mfix $ \(~(Reply _ _ result)) -> do + let a = case result of + OK _ a' -> a' + Error _ -> error "mfix ParsecT" runParsecT (f a) s -instance MonadTrans (ParsecT e s) where +instance (Stream s) => MonadTrans (ParsecT e s) where lift amb = ParsecT $ \s _ _ eok _ -> amb >>= \a -> eok a s mempty instance (Ord e, Stream s) => MonadParsec e s (ParsecT e s m) where - parseError = pParseError - label = pLabel - try = pTry - lookAhead = pLookAhead - notFollowedBy = pNotFollowedBy - withRecovery = pWithRecovery - observing = pObserving - eof = pEof - token = pToken - tokens = pTokens - takeWhileP = pTakeWhileP - takeWhile1P = pTakeWhile1P - takeP = pTakeP - getParserState = pGetParserState + parseError = pParseError + label = pLabel + try = pTry + lookAhead = pLookAhead + notFollowedBy = pNotFollowedBy + withRecovery = pWithRecovery + observing = pObserving + eof = pEof + token = pToken + tokens = pTokens + takeWhileP = pTakeWhileP + takeWhile1P = pTakeWhile1P + takeP = pTakeP + getParserState = pGetParserState updateParserState = pUpdateParserState + mkParsec = pmkParsec -pParseError - :: ParseError s e - -> ParsecT e s m a +pParseError :: + ParseError s e -> + ParsecT e s m a pParseError e = ParsecT $ \s _ _ _ eerr -> eerr e s {-# INLINE pParseError #-} @@ -331,129 +437,139 @@ let el = Label <$> NE.nonEmpty l cok' x s' hs = case el of - Nothing -> cok x s' (refreshLastHint hs Nothing) - Just _ -> cok x s' hs - eok' x s' hs = eok x s' (refreshLastHint hs el) - eerr' err = eerr $ + Nothing -> cok x s' (refreshHints hs Nothing) + Just _ -> cok x s' hs + eok' x s' hs = eok x s' (refreshHints hs el) + eerr' err = eerr $ case err of (TrivialError pos us _) -> TrivialError pos us (maybe E.empty E.singleton el) _ -> err - in unParser p s cok' cerr eok' eerr' + in unParser p s cok' cerr eok' eerr' {-# INLINE pLabel #-} pTry :: ParsecT e s m a -> ParsecT e s m a pTry p = ParsecT $ \s cok _ eok eerr -> let eerr' err _ = eerr err s - in unParser p s cok eerr' eok eerr' + in unParser p s cok eerr' eok eerr' {-# INLINE pTry #-} -pLookAhead :: ParsecT e s m a -> ParsecT e s m a +pLookAhead :: (Stream s) => 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 + in unParser p s eok' cerr eok' eerr {-# INLINE pLookAhead #-} -pNotFollowedBy :: Stream s => ParsecT e s m a -> ParsecT e s m () +pNotFollowedBy :: (Stream s) => ParsecT e s m a -> ParsecT e s m () pNotFollowedBy p = ParsecT $ \s@(State input o _ _) _ _ eok eerr -> let what = maybe EndOfInput (Tokens . nes . fst) (take1_ input) - unexpect u = TrivialError o (pure u) E.empty - cok' _ _ _ = eerr (unexpect what) s - cerr' _ _ = eok () s mempty - eok' _ _ _ = eerr (unexpect what) s - eerr' _ _ = eok () s mempty - in unParser p s cok' cerr' eok' eerr' + unexpected u = TrivialError o (pure u) E.empty + cok' _ _ _ = eerr (unexpected what) s + cerr' _ _ = eok () s mempty + eok' _ _ _ = eerr (unexpected what) s + eerr' _ _ = eok () s mempty + in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-} -pWithRecovery - :: Stream s - => (ParseError s e -> ParsecT e s m a) - -> ParsecT e s m a - -> ParsecT e s m a +pWithRecovery :: + (Stream s) => + (ParseError 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 - rcerr _ _ = cerr err ms + rcerr _ _ = cerr err ms reok x s' _ = eok x s' (toHints (stateOffset s') err) - reerr _ _ = cerr err ms - in unParser (r err) ms rcok rcerr reok reerr + reerr _ _ = cerr err ms + in unParser (r err) ms rcok rcerr reok reerr meerr err ms = let rcok x s' _ = cok x s' (toHints (stateOffset s') err) - rcerr _ _ = eerr err ms + rcerr _ _ = eerr err ms reok x s' _ = eok x s' (toHints (stateOffset s') err) - reerr _ _ = eerr err ms - in unParser (r err) ms rcok rcerr reok reerr - in unParser p s cok mcerr eok meerr + reerr _ _ = eerr err ms + in unParser (r err) ms rcok rcerr reok reerr + in unParser p s cok mcerr eok meerr {-# INLINE pWithRecovery #-} -pObserving - :: Stream s - => ParsecT e s m a - -> ParsecT e s m (Either (ParseError s e) a) +pObserving :: + (Stream s) => + ParsecT e s m a -> + ParsecT e s m (Either (ParseError s e) a) pObserving p = ParsecT $ \s cok _ eok _ -> let cerr' err s' = cok (Left err) s' mempty eerr' err s' = eok (Left err) s' (toHints (stateOffset s') err) - in unParser p s (cok . Right) cerr' (eok . Right) eerr' + in unParser p s (cok . Right) cerr' (eok . Right) eerr' {-# INLINE pObserving #-} -pEof :: forall e s m. Stream s => ParsecT e s m () +pEof :: forall e s m. (Stream s) => ParsecT e s m () pEof = ParsecT $ \s@(State input o pst de) _ _ eok eerr -> case take1_ input of - Nothing -> eok () s mempty - Just (x,_) -> + Nothing -> eok () s mempty + Just (x, _) -> let us = (pure . Tokens . nes) x ps = E.singleton EndOfInput - in eerr (TrivialError o us ps) - (State input o pst de) + in eerr + (TrivialError o us ps) + (State input o pst de) {-# INLINE pEof #-} -pToken :: forall e s m a. Stream s - => (Token s -> Maybe a) - -> Set (ErrorItem (Token s)) - -> ParsecT e s m a +pToken :: + forall e s m a. + (Stream s) => + (Token s -> Maybe a) -> + Set (ErrorItem (Token s)) -> + ParsecT e s m a pToken test ps = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> case take1_ input of Nothing -> let us = pure EndOfInput - in eerr (TrivialError o us ps) s - Just (c,cs) -> + in eerr (TrivialError o us ps) s + Just (c, cs) -> case test c of Nothing -> let us = (Just . Tokens . nes) c - in eerr (TrivialError o us ps) - (State input o pst de) + in eerr + (TrivialError o us ps) + (State input o pst de) Just x -> cok x (State cs (o + 1) pst de) mempty {-# INLINE pToken #-} -pTokens :: forall e s m. Stream s - => (Tokens s -> Tokens s -> Bool) - -> Tokens s - -> ParsecT e s m (Tokens s) +pTokens :: + forall e s m. + (Stream s) => + (Tokens s -> Tokens s -> Bool) -> + Tokens s -> + ParsecT e s m (Tokens s) pTokens f tts = ParsecT $ \s@(State input o pst de) cok _ eok eerr -> let pxy = Proxy :: Proxy s - unexpect pos' u = + unexpected pos' u = let us = pure u ps = (E.singleton . Tokens . NE.fromList . chunkToTokens pxy) tts - in TrivialError pos' us ps + in TrivialError pos' us ps len = chunkLength pxy tts - in case takeN_ len input of - Nothing -> - eerr (unexpect o EndOfInput) s - Just (tts', input') -> - if f tts tts' - then let st = State input' (o + len) pst de - in if chunkEmpty pxy tts - then eok tts' st mempty - else cok tts' st mempty - else let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts' - in eerr (unexpect o ps) (State input o pst de) + in case takeN_ len input of + Nothing -> + eerr (unexpected o EndOfInput) s + Just (tts', input') -> + if f tts tts' + then + let st = State input' (o + len) pst de + in if chunkEmpty pxy tts + then eok tts' st mempty + else cok tts' st mempty + else + let ps = (Tokens . NE.fromList . chunkToTokens pxy) tts' + in eerr (unexpected o ps) (State input o pst de) {-# INLINE pTokens #-} -pTakeWhileP :: forall e s m. Stream s - => Maybe String - -> (Token s -> Bool) - -> ParsecT e s m (Tokens s) +pTakeWhileP :: + forall e s m. + (Stream s) => + Maybe String -> + (Token s -> Bool) -> + ParsecT e s m (Tokens s) pTakeWhileP ml f = ParsecT $ \(State input o pst de) cok _ eok _ -> let pxy = Proxy :: Proxy s (ts, input') = takeWhile_ f input @@ -461,16 +577,18 @@ hs = case ml >>= NE.nonEmpty of Nothing -> mempty - Just l -> (Hints . pure . E.singleton . Label) l - in if chunkEmpty pxy ts - then eok ts (State input' (o + len) pst de) hs - else cok ts (State input' (o + len) pst de) hs + Just l -> (Hints . E.singleton . Label) l + in if chunkEmpty pxy ts + then eok ts (State input' (o + len) pst de) hs + else cok ts (State input' (o + len) pst de) hs {-# INLINE pTakeWhileP #-} -pTakeWhile1P :: forall e s m. Stream s - => Maybe String - -> (Token s -> Bool) - -> ParsecT e s m (Tokens s) +pTakeWhile1P :: + forall e s m. + (Stream s) => + Maybe String -> + (Token s -> Bool) -> + ParsecT e s m (Tokens s) pTakeWhile1P ml f = ParsecT $ \(State input o pst de) cok _ _ eerr -> let pxy = Proxy :: Proxy s (ts, input') = takeWhile_ f input @@ -479,42 +597,49 @@ hs = case el of Nothing -> mempty - Just l -> (Hints . pure . E.singleton) l - in if chunkEmpty pxy ts - then let us = pure $ - case take1_ input of - Nothing -> EndOfInput - Just (t,_) -> Tokens (nes t) - ps = maybe E.empty E.singleton el - in eerr (TrivialError o us ps) - (State input o pst de) - else cok ts (State input' (o + len) pst de) hs + Just l -> (Hints . E.singleton) l + in if chunkEmpty pxy ts + then + let us = pure $ + case take1_ input of + Nothing -> EndOfInput + Just (t, _) -> Tokens (nes t) + ps = maybe E.empty E.singleton el + in eerr + (TrivialError o us ps) + (State input o pst de) + else cok ts (State input' (o + len) pst de) hs {-# INLINE pTakeWhile1P #-} -pTakeP :: forall e s m. Stream s - => Maybe String - -> Int - -> ParsecT e s m (Tokens s) -pTakeP ml n = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> - let pxy = Proxy :: Proxy s +pTakeP :: + forall e s m. + (Stream s) => + Maybe String -> + Int -> + ParsecT e s m (Tokens s) +pTakeP ml n' = ParsecT $ \s@(State input o pst de) cok _ _ eerr -> + let n = max 0 n' + pxy = Proxy :: Proxy s el = Label <$> (ml >>= NE.nonEmpty) ps = maybe E.empty E.singleton el - in case takeN_ n input of - Nothing -> - eerr (TrivialError o (pure EndOfInput) ps) s - Just (ts, input') -> - let len = chunkLength pxy ts - in if len /= n - then eerr (TrivialError (o + len) (pure EndOfInput) ps) - (State input o pst de) - else cok ts (State input' (o + len) pst de) mempty + in case takeN_ n input of + Nothing -> + eerr (TrivialError o (pure EndOfInput) ps) s + Just (ts, input') -> + let len = chunkLength pxy ts + in if len /= n + then + eerr + (TrivialError (o + len) (pure EndOfInput) ps) + (State input o pst de) + else cok ts (State input' (o + len) pst de) mempty {-# INLINE pTakeP #-} -pGetParserState :: ParsecT e s m (State s e) +pGetParserState :: (Stream s) => ParsecT e s m (State s e) pGetParserState = ParsecT $ \s _ _ eok _ -> eok s s mempty {-# INLINE pGetParserState #-} -pUpdateParserState :: (State s e -> State s e) -> ParsecT e s m () +pUpdateParserState :: (Stream s) => (State s e -> State s e) -> ParsecT e s m () pUpdateParserState f = ParsecT $ \s _ _ eok _ -> eok () (f s) mempty {-# INLINE pUpdateParserState #-} @@ -525,13 +650,14 @@ ---------------------------------------------------------------------------- -- Helper functions --- | Convert 'ParseError' record to 'Hints'. - -toHints - :: Stream s - => Int -- ^ Current offset in input stream - -> ParseError s e -- ^ Parse error to convert - -> Hints (Token s) +-- | Convert a 'ParseError' record into 'Hints'. +toHints :: + (Stream s) => + -- | Current offset in input stream + Int -> + -- | Parse error to convert + ParseError s e -> + Hints (Token s) toHints streamPos = \case TrivialError errOffset _ ps -> -- NOTE This is important to check here that the error indeed has @@ -539,91 +665,103 @@ -- there might have been backtracking with 'try' and in that case we -- must not convert such a parse error to hints. if streamPos == errOffset - then Hints (if E.null ps then [] else [ps]) + then Hints (if E.null ps then E.empty else ps) else mempty FancyError _ _ -> mempty {-# INLINE toHints #-} -- | @'withHints' hs c@ makes “error” continuation @c@ use given hints @hs@. -- --- Note that if resulting continuation gets 'ParseError' that has custom +-- __Note__ that if resulting continuation gets 'ParseError' that has custom -- data in it, hints are ignored. - -withHints - :: Stream s - => Hints (Token s) -- ^ Hints to use - -> (ParseError s e -> State s e -> m b) -- ^ Continuation to influence - -> ParseError s e -- ^ First argument of resulting continuation - -> State s e -- ^ Second argument of resulting continuation - -> m b +withHints :: + (Stream s) => + -- | Hints to use + Hints (Token s) -> + -- | Continuation to influence + (ParseError s e -> State s e -> m b) -> + -- | First argument of resulting continuation + ParseError s e -> + -- | Second argument of resulting continuation + State s e -> + m b withHints (Hints ps') c e = case e of - TrivialError pos us ps -> c (TrivialError pos us (E.unions (ps : ps'))) + TrivialError pos us ps -> c (TrivialError pos us (E.union ps ps')) _ -> c e {-# INLINE withHints #-} -- | @'accHints' hs c@ results in “OK” continuation that will add given -- hints @hs@ to third argument of original continuation @c@. - -accHints - :: Hints t -- ^ 'Hints' to add - -> (a -> State s e -> Hints t -> m b) -- ^ An “OK” continuation to alter - -> (a -> State s e -> Hints t -> m b) -- ^ Altered “OK” continuation +accHints :: + (Stream s) => + -- | 'Hints' to add + Hints (Token s) -> + -- | An “OK” continuation to alter + (a -> State s e -> Hints (Token s) -> m b) -> + -- | Altered “OK” continuation + (a -> State s e -> Hints (Token s) -> m b) accHints hs1 c x s hs2 = c x s (hs1 <> hs2) {-# INLINE accHints #-} --- | Replace the most recent group of hints (if any) with the given --- 'ErrorItem' (or delete it if 'Nothing' is given). This is used in the --- 'label' primitive. - -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 #-} +-- | Replace the hints with the given 'ErrorItem' (or delete it if 'Nothing' +-- is given). This is used in the 'label' primitive. +refreshHints :: Hints t -> Maybe (ErrorItem t) -> Hints t +refreshHints (Hints _) Nothing = Hints E.empty +refreshHints (Hints hs) (Just m) = + if E.null hs + then Hints hs + else Hints (E.singleton m) +{-# INLINE refreshHints #-} -- | Low-level unpacking of the 'ParsecT' type. - -runParsecT :: Monad m - => ParsecT e s m a -- ^ Parser to run - -> State s e -- ^ Initial state - -> m (Reply e s a) +runParsecT :: + (Monad m) => + -- | Parser to run + ParsecT e s m a -> + -- | Initial state + State s e -> + 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) + cok a s' hs = return $ Reply s' Consumed (OK hs 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) + eok a s' hs = return $ Reply s' NotConsumed (OK hs a) + eerr err s' = return $ Reply s' NotConsumed (Error err) -- | Transform any custom errors thrown by the parser using the given -- function. Similar in function and purpose to @withExceptT@. -- --- __Note__ that the inner parser will start with empty collection of +-- __Note__ that the inner parser will start with an empty collection of -- “delayed” 'ParseError's. Any delayed 'ParseError's produced in the inner -- parser will be lifted by applying the provided function and added to the -- collection of delayed parse errors of the outer parser. -- -- @since 7.0.0 - -withParsecT :: forall e e' s m a. (Monad m, Ord e') - => (e -> e') - -> ParsecT e s m a -- ^ Inner parser - -> ParsecT e' s m a -- ^ Outer parser +withParsecT :: + forall e e' s m a. + (Ord e') => + (e -> e') -> + -- | Inner parser + ParsecT e s m a -> + -- | Outer parser + ParsecT e' s m a withParsecT f p = ParsecT $ \s cok cerr eok eerr -> - let s' = s - { stateParseErrors = [] - } + let s' = + s + { stateParseErrors = [] + } adjustState :: State s e -> State s e' - adjustState st = st - { stateParseErrors = - (mapParseError f <$> stateParseErrors st) - ++ stateParseErrors s - } + adjustState st = + st + { stateParseErrors = + (mapParseError f <$> stateParseErrors st) + ++ stateParseErrors s + } cok' x st hs = cok x (adjustState st) hs cerr' e st = cerr (mapParseError f e) (adjustState st) eok' x st hs = eok x (adjustState st) hs eerr' e st = eerr (mapParseError f e) (adjustState st) - in unParser p s' cok' cerr' eok' eerr' - where + in unParser p s' cok' cerr' eok' eerr' {-# INLINE withParsecT #-} diff --git a/Text/Megaparsec/Internal.hs-boot b/Text/Megaparsec/Internal.hs-boot new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Internal.hs-boot @@ -0,0 +1,10 @@ +{-# LANGUAGE RoleAnnotations #-} + +module Text.Megaparsec.Internal + ( Reply, + ) +where + +type role Reply nominal nominal representational + +data Reply e s a diff --git a/Text/Megaparsec/Lexer.hs b/Text/Megaparsec/Lexer.hs --- a/Text/Megaparsec/Lexer.hs +++ b/Text/Megaparsec/Lexer.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} + -- | -- Module : Text.Megaparsec.Common -- Copyright : © 2018–present Megaparsec contributors @@ -11,36 +14,35 @@ -- it are re-exported in "Text.Megaparsec.Byte" and "Text.Megaparsec.Char". -- -- @since 7.0.0 - -{-# LANGUAGE FlexibleContexts #-} - module Text.Megaparsec.Lexer ( -- * White space - space - , lexeme - , symbol - , symbol' ) + space, + lexeme, + symbol, + symbol', + ) where +import qualified Data.CaseInsensitive as CI import Text.Megaparsec import Text.Megaparsec.Common -import qualified Data.CaseInsensitive as CI ---------------------------------------------------------------------------- -- White space --- | @'space' sc lineComment blockComment@ produces parser that can parse +-- | @'space' sc lineComment blockComment@ produces a parser that can parse -- white space in general. It's expected that you create such a parser once -- and pass it to other functions in this module as needed (when you see -- @spaceConsumer@ in documentation, usually it means that something like -- 'space' is expected there). -- --- @sc@ is used to parse blocks of space characters. You can use 'C.space1' --- from "Text.Megaparsec.Char" for this purpose as well as your own parser --- (if you don't want to automatically consume newlines, for example). Make --- sure the parser does not succeed on empty input though. In earlier --- version 'C.spaceChar' was recommended, but now parsers based on --- 'takeWhile1P' are preferred because of their speed. +-- @sc@ is used to parse blocks of space characters. You can use +-- 'Text.Megaparsec.Char.space1' from "Text.Megaparsec.Char" for this +-- purpose as well as your own parser (if you don't want to automatically +-- consume newlines, for example). Make sure that the parser does not +-- succeed on the empty input though. In an earlier version of the library +-- 'Text.Megaparsec.Char.spaceChar' was recommended, but now parsers based +-- on 'takeWhile1P' are preferred because of their speed. -- -- @lineComment@ is used to parse line comments. You can use -- @skipLineComment@ if you don't need anything special. @@ -53,28 +55,35 @@ -- will fail instantly when parsing of that sort of comment is attempted and -- 'space' will just move on or finish depending on whether there is more -- white space for it to consume. - -space :: MonadParsec e s m - => m () -- ^ A parser for space characters which does not accept empty - -- input (e.g. 'C.space1') - -> m () -- ^ A parser for a line comment (e.g. 'skipLineComment') - -> m () -- ^ A parser for a block comment (e.g. 'skipBlockComment') - -> m () -space sp line block = skipMany $ choice - [hidden sp, hidden line, hidden block] +space :: + (MonadParsec e s m) => + -- | A parser for space characters which does not accept empty + -- input (e.g. 'Text.Megaparsec.Char.space1') + m () -> + -- | A parser for a line comment (e.g. 'skipLineComment') + m () -> + -- | A parser for a block comment (e.g. 'skipBlockComment') + m () -> + m () +space sp line block = + skipMany $ + choice + [hidden sp, hidden line, hidden block] {-# INLINEABLE space #-} --- | This is a wrapper for lexemes. Typical usage is to supply the first +-- | This is a wrapper for lexemes. The typical usage is to supply the first -- argument (parser that consumes white space, probably defined via 'space') -- and use the resulting function to wrap parsers for every lexeme. -- -- > lexeme = L.lexeme spaceConsumer -- > integer = lexeme L.decimal - -lexeme :: MonadParsec e s m - => m () -- ^ How to consume white space after lexeme - -> m a -- ^ How to parse actual lexeme - -> m a +lexeme :: + (MonadParsec e s m) => + -- | How to consume white space after lexeme + m () -> + -- | How to parse actual lexeme + m a -> + m a lexeme spc p = p <* spc {-# INLINEABLE lexeme #-} @@ -92,20 +101,24 @@ -- > comma = symbol "," -- > colon = symbol ":" -- > dot = symbol "." - -symbol :: MonadParsec e s m - => m () -- ^ How to consume white space after lexeme - -> Tokens s -- ^ Symbol to parse - -> m (Tokens s) +symbol :: + (MonadParsec e s m) => + -- | How to consume white space after lexeme + m () -> + -- | Symbol to parse + Tokens s -> + m (Tokens s) symbol spc = lexeme spc . string {-# INLINEABLE symbol #-} --- | Case-insensitive version of 'symbol'. This may be helpful if you're +-- | A case-insensitive version of 'symbol'. This may be helpful if you're -- working with case-insensitive languages. - -symbol' :: (MonadParsec e s m, CI.FoldCase (Tokens s)) - => m () -- ^ How to consume white space after lexeme - -> Tokens s -- ^ Symbol to parse (case-insensitive) - -> m (Tokens s) +symbol' :: + (MonadParsec e s m, CI.FoldCase (Tokens s)) => + -- | How to consume white space after lexeme + m () -> + -- | Symbol to parse (case-insensitive) + Tokens s -> + m (Tokens s) symbol' spc = lexeme spc . string' {-# INLINEABLE symbol' #-} diff --git a/Text/Megaparsec/Pos.hs b/Text/Megaparsec/Pos.hs --- a/Text/Megaparsec/Pos.hs +++ b/Text/Megaparsec/Pos.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + -- | -- Module : Text.Megaparsec.Pos -- Copyright : © 2015–present Megaparsec contributors @@ -12,29 +17,25 @@ -- -- You probably do not want to import this module directly because -- "Text.Megaparsec" re-exports it anyway. - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Text.Megaparsec.Pos ( -- * Abstract position - Pos - , mkPos - , unPos - , pos1 - , defaultTabWidth - , InvalidPosException (..) + Pos, + mkPos, + unPos, + pos1, + defaultTabWidth, + InvalidPosException (..), + -- * Source position - , SourcePos (..) - , initialPos - , sourcePosPretty ) + SourcePos (..), + initialPos, + sourcePosPretty, + ) where import Control.DeepSeq import Control.Exception import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics ---------------------------------------------------------------------------- @@ -46,15 +47,13 @@ -- together. -- -- @since 5.0.0 - newtype Pos = Pos Int - deriving (Show, Eq, Ord, Data, Typeable, NFData) + deriving (Show, Eq, Ord, Data, Generic, NFData) -- | Construction of 'Pos' from 'Int'. The function throws -- 'InvalidPosException' when given a non-positive argument. -- -- @since 6.0.0 - mkPos :: Int -> Pos mkPos a = if a <= 0 @@ -65,7 +64,6 @@ -- | Extract 'Int' from 'Pos'. -- -- @since 6.0.0 - unPos :: Pos -> Int unPos (Pos w) = w {-# INLINE unPos #-} @@ -73,7 +71,6 @@ -- | Position with value 1. -- -- @since 6.0.0 - pos1 :: Pos pos1 = mkPos 1 @@ -86,7 +83,6 @@ -- > defaultTabWidth = mkPos 8 -- -- @since 5.0.0 - defaultTabWidth :: Pos defaultTabWidth = mkPos 8 @@ -98,21 +94,22 @@ readsPrec d = readParen (d > 10) $ \r1 -> do ("Pos", r2) <- lex r1 - (x, r3) <- readsPrec 11 r2 + (x, r3) <- readsPrec 11 r2 return (mkPos x, r3) -- | The exception is thrown by 'mkPos' when its argument is not a positive -- number. -- -- @since 5.0.0 - -newtype InvalidPosException = InvalidPosException Int - -- ^ Contains the actual value that was passed to 'mkPos' - deriving (Eq, Show, Data, Typeable, Generic) +newtype InvalidPosException + = -- | Contains the actual value that was passed to 'mkPos' + InvalidPosException Int + deriving (Eq, Show, Data, Generic) instance Exception InvalidPosException -instance NFData InvalidPosException +instance NFData InvalidPosException + ---------------------------------------------------------------------------- -- Source position @@ -120,28 +117,29 @@ -- 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. - data SourcePos = SourcePos - { sourceName :: FilePath -- ^ Name of source file - , sourceLine :: !Pos -- ^ Line number - , sourceColumn :: !Pos -- ^ Column number - } deriving (Show, Read, Eq, Ord, Data, Typeable, Generic) + { -- | Name of source file + sourceName :: FilePath, + -- | Line number + sourceLine :: !Pos, + -- | Column number + sourceColumn :: !Pos + } + deriving (Show, Read, Eq, Ord, Data, Generic) instance NFData SourcePos -- | Construct initial position (line 1, column 1) given name of source -- file. - initialPos :: FilePath -> SourcePos initialPos n = SourcePos n pos1 pos1 -- | Pretty-print a 'SourcePos'. -- -- @since 5.0.0 - sourcePosPretty :: SourcePos -> String sourcePosPretty (SourcePos n l c) - | null n = showLC + | null n = showLC | otherwise = n <> ":" <> showLC where showLC = show (unPos l) <> ":" <> show (unPos c) diff --git a/Text/Megaparsec/State.hs b/Text/Megaparsec/State.hs --- a/Text/Megaparsec/State.hs +++ b/Text/Megaparsec/State.hs @@ -1,3 +1,10 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.State -- Copyright : © 2015–present Megaparsec contributors @@ -12,77 +19,115 @@ -- Definition of Megaparsec's 'State'. -- -- @since 6.5.0 - -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE UndecidableInstances #-} - module Text.Megaparsec.State - ( State (..) - , PosState (..) ) + ( State (..), + initialState, + PosState (..), + initialPosState, + ) where import Control.DeepSeq (NFData) import Data.Data (Data) -import Data.Typeable (Typeable) import GHC.Generics -import Text.Megaparsec.Pos import {-# SOURCE #-} Text.Megaparsec.Error (ParseError) +import Text.Megaparsec.Pos -- | This is the Megaparsec's state parametrized over stream type @s@ and -- custom error component type @e@. - data State s e = State - { stateInput :: s - -- ^ The rest of input to process - , stateOffset :: {-# UNPACK #-} !Int - -- ^ Number of processed tokens so far + { -- | The rest of input to process + stateInput :: s, + -- | Number of processed tokens so far -- -- @since 7.0.0 - , statePosState :: PosState s - -- ^ State that is used for line\/column calculation + stateOffset :: {-# UNPACK #-} !Int, + -- | State that is used for line\/column calculation -- -- @since 7.0.0 - , stateParseErrors :: [ParseError s e] - -- ^ Collection of “delayed” 'ParseError's in reverse order. This means + statePosState :: PosState s, + -- | Collection of “delayed” 'ParseError's in reverse order. This means -- that the last registered error is the first element of the list. -- -- @since 8.0.0 - } deriving (Typeable, Generic) + stateParseErrors :: [ParseError s e] + } + deriving (Generic) -deriving instance ( Show (ParseError s e) - , Show s - ) => Show (State s e) +deriving instance + ( Show (ParseError s e), + Show s + ) => + Show (State s e) -deriving instance ( Eq (ParseError s e) - , Eq s - ) => Eq (State s e) +deriving instance + ( Eq (ParseError s e), + Eq s + ) => + Eq (State s e) -deriving instance ( Data e - , Data (ParseError s e) - , Data s - ) => Data (State s e) +deriving instance + ( Data e, + Data (ParseError s e), + Data s + ) => + Data (State s e) instance (NFData s, NFData (ParseError s e)) => NFData (State s e) --- | Special kind of state that is used to calculate line\/column positions --- on demand. +-- | Given the name of the source file and the input construct the initial +-- state for a parser. -- --- @since 7.0.0 +-- @since 9.6.0 +initialState :: + -- | Name of the file the input is coming from + FilePath -> + -- | Input + s -> + State s e +initialState name s = + State + { stateInput = s, + stateOffset = 0, + statePosState = initialPosState name s, + stateParseErrors = [] + } +-- | A special kind of state that is used to calculate line\/column +-- positions on demand. +-- +-- @since 7.0.0 data PosState s = PosState - { pstateInput :: s - -- ^ The rest of input to process - , pstateOffset :: !Int - -- ^ Offset corresponding to beginning of 'pstateInput' - , pstateSourcePos :: !SourcePos - -- ^ Source position corresponding to beginning of 'pstateInput' - , pstateTabWidth :: Pos - -- ^ Tab width to use for column calculation - , pstateLinePrefix :: String - -- ^ Prefix to prepend to offending line - } deriving (Show, Eq, Data, Typeable, Generic) + { -- | The rest of input to process + pstateInput :: s, + -- | Offset corresponding to beginning of 'pstateInput' + pstateOffset :: !Int, + -- | Source position corresponding to beginning of 'pstateInput' + pstateSourcePos :: !SourcePos, + -- | Tab width to use for column calculation + pstateTabWidth :: Pos, + -- | Prefix to prepend to offending line + pstateLinePrefix :: String + } + deriving (Show, Eq, Data, Generic) -instance NFData s => NFData (PosState s) +instance (NFData s) => NFData (PosState s) + +-- | Given the name of source file and the input construct the initial +-- positional state. +-- +-- @since 9.6.0 +initialPosState :: + -- | Name of the file the input is coming from + FilePath -> + -- | Input + s -> + PosState s +initialPosState name s = + PosState + { pstateInput = s, + pstateOffset = 0, + pstateSourcePos = initialPos name, + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } diff --git a/Text/Megaparsec/Stream.hs b/Text/Megaparsec/Stream.hs --- a/Text/Megaparsec/Stream.hs +++ b/Text/Megaparsec/Stream.hs @@ -1,3 +1,15 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Text.Megaparsec.Stream -- Copyright : © 2015–present Megaparsec contributors @@ -13,47 +25,51 @@ -- "Text.Megaparsec" re-exports it anyway. -- -- @since 6.0.0 - -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} - module Text.Megaparsec.Stream - ( Stream (..) ) + ( Stream (..), + ShareInput (..), + NoShareInput (..), + VisualStream (..), + TraversableStream (..), + ) where +import Data.Bifunctor (second) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (chr) -import Data.Foldable (foldl') +import Data.Foldable (toList) import Data.Kind (Type) +import qualified Data.List import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe) import Data.Proxy +import qualified Data.Sequence as S +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import Data.Word (Word8) import Text.Megaparsec.Pos import Text.Megaparsec.State -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Lazy.Char8 as BL8 -import qualified Data.List.NonEmpty as NE -import qualified Data.Text as T -import qualified Data.Text.Lazy as TL +import qualified Text.Megaparsec.Unicode as Unicode -- | Type class for inputs that can be consumed by the library. - +-- +-- Note that the 'Stream' instances for 'Text' and 'ByteString' (strict and +-- lazy) default to "input sharing" (see 'ShareInput', 'NoShareInput'). We plan +-- to move away from input sharing in a future major release; if you want to +-- retain the current behaviour and are concerned with maximum performance you +-- should consider using the 'ShareInput' wrapper explicitly. +-- +-- __Note__: before the version /9.0.0/ the class included the methods from +-- 'VisualStream' and 'TraversableStream'. class (Ord (Token s), Ord (Tokens s)) => Stream s where - -- | Type of token in the stream. - type Token s :: Type -- | Type of “chunk” of the stream. - type Tokens s :: Type -- | Lift a single token to chunk of the stream. The default @@ -63,26 +79,22 @@ -- -- However for some types of stream there may be a more efficient way to -- lift. - - tokenToChunk :: Proxy s -> Token s -> Tokens s + tokenToChunk :: Proxy s -> Token s -> Tokens s tokenToChunk pxy = tokensToChunk pxy . pure -- | The first method that establishes isomorphism between list of tokens -- and chunk of the stream. Valid implementation should satisfy: -- -- > chunkToTokens pxy (tokensToChunk pxy ts) == ts - tokensToChunk :: Proxy s -> [Token s] -> Tokens s -- | The second method that establishes isomorphism between list of tokens -- and chunk of the stream. Valid implementation should satisfy: -- -- > tokensToChunk pxy (chunkToTokens pxy chunk) == chunk - chunkToTokens :: Proxy s -> Tokens s -> [Token s] -- | Return length of a chunk of the stream. - chunkLength :: Proxy s -> Tokens s -> Int -- | Check if a chunk of the stream is empty. The default implementation @@ -91,13 +103,11 @@ -- > chunkEmpty pxy ts = chunkLength pxy ts <= 0 -- -- However for many streams there may be a more efficient implementation. - chunkEmpty :: Proxy s -> Tokens s -> Bool chunkEmpty pxy ts = chunkLength pxy ts <= 0 -- | Extract a single token form the stream. Return 'Nothing' if the -- stream is empty. - take1_ :: s -> Maybe (Token s, s) -- | @'takeN_' n s@ should try to extract a chunk of length @n@, or if the @@ -113,7 +123,6 @@ -- * In other cases, take chunk of length @n@ (or shorter if the -- stream is not long enough) from the input stream and return the -- chunk along with the rest of the stream. - takeN_ :: Int -> s -> Maybe (Tokens s, s) -- | Extract chunk of the stream taking tokens while the supplied @@ -122,14 +131,291 @@ -- For many types of streams, the method allows for significant -- performance improvements, although it is not strictly necessary from -- conceptual point of view. - takeWhile_ :: (Token s -> Bool) -> s -> (Tokens s, s) +-- | @since 9.0.0 +instance (Ord a) => Stream [a] where + type Token [a] = a + type Tokens [a] = [a] + tokenToChunk Proxy = pure + tokensToChunk Proxy = id + chunkToTokens Proxy = id + chunkLength Proxy = length + chunkEmpty Proxy = null + take1_ [] = Nothing + take1_ (t : ts) = Just (t, ts) + takeN_ n s + | n <= 0 = Just ([], s) + | null s = Nothing + | otherwise = Just (splitAt n s) + takeWhile_ = span + +-- | @since 9.0.0 +instance (Ord a) => Stream (S.Seq a) where + type Token (S.Seq a) = a + type Tokens (S.Seq a) = S.Seq a + tokenToChunk Proxy = pure + tokensToChunk Proxy = S.fromList + chunkToTokens Proxy = toList + chunkLength Proxy = length + chunkEmpty Proxy = null + take1_ S.Empty = Nothing + take1_ (t S.:<| ts) = Just (t, ts) + takeN_ n s + | n <= 0 = Just (S.empty, s) + | null s = Nothing + | otherwise = Just (S.splitAt n s) + takeWhile_ = S.spanl + +-- | This wrapper selects the input-sharing 'Stream' implementation for +-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). By input +-- sharing we mean that our parsers will use slices whenever possible to +-- avoid having to copy parts of the input. See also the documentation of +-- 'T.split'. +-- +-- Note that using slices is in general faster than copying; on the other +-- hand it also has the potential for causing surprising memory leaks: if +-- any slice of the input survives in the output, holding on to the output +-- will force the entire input 'T.Text'/'B.ByteString' to stay in memory! +-- Even when using lazy 'TL.Text'/'BL.ByteString' we will hold on to whole +-- chunks at a time leading to to significantly worse memory residency in +-- some cases. +-- +-- See 'NoShareInput' for a somewhat slower implementation that avoids this +-- memory leak scenario. +-- +-- @since 9.3.0 +newtype ShareInput a = ShareInput {unShareInput :: a} + +instance Stream (ShareInput B.ByteString) where + type Token (ShareInput B.ByteString) = Word8 + type Tokens (ShareInput B.ByteString) = B.ByteString + tokenToChunk Proxy = B.singleton + tokensToChunk Proxy = B.pack + chunkToTokens Proxy = B.unpack + chunkLength Proxy = B.length + chunkEmpty Proxy = B.null + take1_ (ShareInput s) = second ShareInput <$> B.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (B.empty, ShareInput s) + | B.null s = Nothing + | otherwise = Just . second ShareInput $ B.splitAt n s + takeWhile_ p (ShareInput s) = second ShareInput $ B.span p s + +instance Stream (ShareInput BL.ByteString) where + type Token (ShareInput BL.ByteString) = Word8 + type Tokens (ShareInput BL.ByteString) = BL.ByteString + tokenToChunk Proxy = BL.singleton + tokensToChunk Proxy = BL.pack + chunkToTokens Proxy = BL.unpack + chunkLength Proxy = fromIntegral . BL.length + chunkEmpty Proxy = BL.null + take1_ (ShareInput s) = second ShareInput <$> BL.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (BL.empty, ShareInput s) + | BL.null s = Nothing + | otherwise = Just . second ShareInput $ BL.splitAt (fromIntegral n) s + takeWhile_ p (ShareInput s) = second ShareInput $ BL.span p s + +instance Stream (ShareInput T.Text) where + type Token (ShareInput T.Text) = Char + type Tokens (ShareInput T.Text) = T.Text + tokenToChunk Proxy = T.singleton + tokensToChunk Proxy = T.pack + chunkToTokens Proxy = T.unpack + chunkLength Proxy = T.length + chunkEmpty Proxy = T.null + take1_ (ShareInput s) = second ShareInput <$> T.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (T.empty, ShareInput s) + | T.null s = Nothing + | otherwise = Just . second ShareInput $ T.splitAt n s + takeWhile_ p (ShareInput s) = second ShareInput $ T.span p s + +instance Stream (ShareInput TL.Text) where + type Token (ShareInput TL.Text) = Char + type Tokens (ShareInput TL.Text) = TL.Text + tokenToChunk Proxy = TL.singleton + tokensToChunk Proxy = TL.pack + chunkToTokens Proxy = TL.unpack + chunkLength Proxy = fromIntegral . TL.length + chunkEmpty Proxy = TL.null + take1_ (ShareInput s) = second ShareInput <$> TL.uncons s + takeN_ n (ShareInput s) + | n <= 0 = Just (TL.empty, ShareInput s) + | TL.null s = Nothing + | otherwise = Just . second ShareInput $ TL.splitAt (fromIntegral n) s + takeWhile_ p (ShareInput s) = second ShareInput $ TL.span p s + +-- | This wrapper selects the no-input-sharing 'Stream' implementation for +-- 'T.Text' ('TL.Text') and 'B.ByteString' ('BL.ByteString'). This means +-- that our parsers will create independent copies rather than using slices +-- of the input. See also the documentation of 'T.copy'. +-- +-- More importantly, any parser output will be independent of the input, and +-- holding on to parts of the output will never prevent the input from being +-- garbage collected. +-- +-- For maximum performance you might consider using 'ShareInput' instead, +-- but beware of its pitfalls! +-- +-- @since 9.3.0 +newtype NoShareInput a = NoShareInput {unNoShareInput :: a} + +instance Stream (NoShareInput B.ByteString) where + type Token (NoShareInput B.ByteString) = Word8 + type Tokens (NoShareInput B.ByteString) = B.ByteString + tokenToChunk Proxy = B.singleton + tokensToChunk Proxy = B.pack + chunkToTokens Proxy = B.unpack + chunkLength Proxy = B.length + chunkEmpty Proxy = B.null + take1_ (NoShareInput s) = second NoShareInput <$> B.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (B.empty, NoShareInput s) + | B.null s = Nothing + | otherwise = + let (result, rest) = B.splitAt n s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = B.copy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = B.span p s + -- Ditto. + unSharedResult = B.copy result + in (unSharedResult, NoShareInput rest) + +instance Stream (NoShareInput BL.ByteString) where + type Token (NoShareInput BL.ByteString) = Word8 + type Tokens (NoShareInput BL.ByteString) = BL.ByteString + tokenToChunk Proxy = BL.singleton + tokensToChunk Proxy = BL.pack + chunkToTokens Proxy = BL.unpack + chunkLength Proxy = fromIntegral . BL.length + chunkEmpty Proxy = BL.null + take1_ (NoShareInput s) = second NoShareInput <$> BL.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (BL.empty, NoShareInput s) + | BL.null s = Nothing + | otherwise = + let (result, rest) = BL.splitAt (fromIntegral n) s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = BL.copy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = BL.span p s + -- Ditto. + unSharedResult = BL.copy result + in (unSharedResult, NoShareInput rest) + +instance Stream (NoShareInput T.Text) where + type Token (NoShareInput T.Text) = Char + type Tokens (NoShareInput T.Text) = T.Text + tokenToChunk Proxy = T.singleton + tokensToChunk Proxy = T.pack + chunkToTokens Proxy = T.unpack + chunkLength Proxy = T.length + chunkEmpty Proxy = T.null + take1_ (NoShareInput s) = second NoShareInput <$> T.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (T.empty, NoShareInput s) + | T.null s = Nothing + | otherwise = + let (result, rest) = T.splitAt n s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = T.copy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = T.span p s + unSharedResult = T.copy result + in (unSharedResult, NoShareInput rest) + +instance Stream (NoShareInput TL.Text) where + type Token (NoShareInput TL.Text) = Char + type Tokens (NoShareInput TL.Text) = TL.Text + tokenToChunk Proxy = TL.singleton + tokensToChunk Proxy = TL.pack + chunkToTokens Proxy = TL.unpack + chunkLength Proxy = fromIntegral . TL.length + chunkEmpty Proxy = TL.null + take1_ (NoShareInput s) = second NoShareInput <$> TL.uncons s + takeN_ n (NoShareInput s) + | n <= 0 = Just (TL.empty, NoShareInput s) + | TL.null s = Nothing + | otherwise = + let (result, rest) = TL.splitAt (fromIntegral n) s + -- To avoid sharing the entire input we create a clean copy of the result. + unSharedResult = tlCopy result + in Just (unSharedResult, NoShareInput rest) + takeWhile_ p (NoShareInput s) = + let (result, rest) = TL.span p s + unSharedResult = tlCopy result + in (unSharedResult, NoShareInput rest) + +-- | Create an independent copy of a TL.Text, akin to BL.copy. +tlCopy :: TL.Text -> TL.Text +tlCopy = TL.fromStrict . T.copy . TL.toStrict +{-# INLINE tlCopy #-} + +-- Since we are using @{-# LANGUAGE Safe #-}@ we can't use deriving via in +-- these cases. + +instance Stream B.ByteString where + type Token B.ByteString = Token (ShareInput B.ByteString) + type Tokens B.ByteString = Tokens (ShareInput B.ByteString) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput B.ByteString)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput B.ByteString)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput B.ByteString)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput B.ByteString)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput B.ByteString)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +instance Stream BL.ByteString where + type Token BL.ByteString = Token (ShareInput BL.ByteString) + type Tokens BL.ByteString = Tokens (ShareInput BL.ByteString) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput BL.ByteString)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput BL.ByteString)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput BL.ByteString)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput BL.ByteString)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput BL.ByteString)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +instance Stream T.Text where + type Token T.Text = Token (ShareInput T.Text) + type Tokens T.Text = Tokens (ShareInput T.Text) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput T.Text)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput T.Text)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput T.Text)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput T.Text)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput T.Text)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +instance Stream TL.Text where + type Token TL.Text = Token (ShareInput TL.Text) + type Tokens TL.Text = Tokens (ShareInput TL.Text) + tokenToChunk Proxy = tokenToChunk (Proxy :: Proxy (ShareInput TL.Text)) + tokensToChunk Proxy = tokensToChunk (Proxy :: Proxy (ShareInput TL.Text)) + chunkToTokens Proxy = chunkToTokens (Proxy :: Proxy (ShareInput TL.Text)) + chunkLength Proxy = chunkLength (Proxy :: Proxy (ShareInput TL.Text)) + chunkEmpty Proxy = chunkEmpty (Proxy :: Proxy (ShareInput TL.Text)) + take1_ s = second unShareInput <$> take1_ (ShareInput s) + takeN_ n s = second unShareInput <$> takeN_ n (ShareInput s) + takeWhile_ p s = second unShareInput $ takeWhile_ p (ShareInput s) + +-- | Type class for inputs that can also be used for debugging. +-- +-- @since 9.0.0 +class (Stream s) => VisualStream s where -- | Pretty-print non-empty stream of tokens. This function is also used -- to print single tokens (represented as singleton lists). -- -- @since 7.0.0 - showTokens :: Proxy s -> NonEmpty (Token s) -> String -- | Return the number of characters that a non-empty stream of tokens @@ -137,17 +423,42 @@ -- exactly 1 character. -- -- @since 8.0.0 - tokensLength :: Proxy s -> NonEmpty (Token s) -> Int tokensLength Proxy = NE.length +instance VisualStream String where + showTokens Proxy = stringPretty + tokensLength Proxy = Unicode.stringLength + +instance VisualStream B.ByteString where + showTokens Proxy = stringPretty . fmap (chr . fromIntegral) + +instance VisualStream BL.ByteString where + showTokens Proxy = stringPretty . fmap (chr . fromIntegral) + +instance VisualStream T.Text where + showTokens Proxy = stringPretty + tokensLength Proxy = Unicode.stringLength + +instance VisualStream TL.Text where + showTokens Proxy = stringPretty + tokensLength Proxy = Unicode.stringLength + +-- | Type class for inputs that can also be used for error reporting. +-- +-- @since 9.0.0 +class (Stream s) => TraversableStream s where + {-# MINIMAL reachOffset | reachOffsetNoLine #-} + -- | Given an offset @o@ and initial 'PosState', adjust the state in such -- a way that it starts at the offset. -- -- Return two values (in order): -- - -- * 'String' representing the line on which the given offset @o@ is - -- located. The line should satisfy a number of conditions that are + -- * 'Maybe' 'String' representing the line on which the given offset + -- @o@ is located. It can be omitted (i.e. 'Nothing'); in that case + -- error reporting functions will not show offending lines. If + -- returned, the line should satisfy a number of conditions that are -- described below. -- * The updated 'PosState' which can be in turn used to locate -- another offset @o'@ given that @o' >= o@. @@ -166,14 +477,18 @@ -- 'PosState'. -- -- __Note__: type signature of the function was changed in the version - -- /8.0.0/. + -- /9.0.0/. -- -- @since 7.0.0 - - reachOffset - :: Int -- ^ Offset to reach - -> PosState s -- ^ Initial 'PosState' to use - -> (String, PosState s) -- ^ See the description of the function + reachOffset :: + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | See the description of the function + (Maybe String, PosState s) + reachOffset o pst = + (Nothing, reachOffsetNoLine o pst) -- | A version of 'reachOffset' that may be faster because it doesn't need -- to fetch the line at which the given offset in located. @@ -187,280 +502,218 @@ -- /8.0.0/. -- -- @since 7.0.0 - - reachOffsetNoLine - :: Int -- ^ Offset to reach - -> PosState s -- ^ Initial 'PosState' to use - -> PosState s -- ^ Reached source position and updated state + reachOffsetNoLine :: + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | Reached source position and updated state + PosState s reachOffsetNoLine o pst = snd (reachOffset o pst) -instance Stream String where - type Token String = Char - type Tokens String = String - tokenToChunk Proxy = pure - tokensToChunk Proxy = id - chunkToTokens Proxy = id - chunkLength Proxy = length - chunkEmpty Proxy = null - take1_ [] = Nothing - take1_ (t:ts) = Just (t, ts) - takeN_ n s - | n <= 0 = Just ("", s) - | null s = Nothing - | otherwise = Just (splitAt n s) - takeWhile_ = span - showTokens Proxy = stringPretty +instance TraversableStream String where -- NOTE Do not eta-reduce these (breaks inlining) reachOffset o pst = - reachOffset' splitAt foldl' id id ('\n','\t') o pst + reachOffset' splitAt Data.List.foldl' id id ('\n', '\t') charInc o pst reachOffsetNoLine o pst = - reachOffsetNoLine' splitAt foldl' ('\n', '\t') o pst + reachOffsetNoLine' splitAt Data.List.foldl' ('\n', '\t') charInc o pst -instance Stream B.ByteString where - type Token B.ByteString = Word8 - type Tokens B.ByteString = B.ByteString - tokenToChunk Proxy = B.singleton - tokensToChunk Proxy = B.pack - chunkToTokens Proxy = B.unpack - chunkLength Proxy = B.length - chunkEmpty Proxy = B.null - take1_ = B.uncons - takeN_ n s - | n <= 0 = Just (B.empty, s) - | B.null s = Nothing - | otherwise = Just (B.splitAt n s) - takeWhile_ = B.span - showTokens Proxy = stringPretty . fmap (chr . fromIntegral) +instance TraversableStream B.ByteString where -- NOTE Do not eta-reduce these (breaks inlining) reachOffset o pst = - reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) o pst + reachOffset' B.splitAt B.foldl' B8.unpack (chr . fromIntegral) (10, 9) byteInc o pst reachOffsetNoLine o pst = - reachOffsetNoLine' B.splitAt B.foldl' (10, 9) o pst + reachOffsetNoLine' B.splitAt B.foldl' (10, 9) byteInc o pst -instance Stream BL.ByteString where - type Token BL.ByteString = Word8 - type Tokens BL.ByteString = BL.ByteString - tokenToChunk Proxy = BL.singleton - tokensToChunk Proxy = BL.pack - chunkToTokens Proxy = BL.unpack - chunkLength Proxy = fromIntegral . BL.length - chunkEmpty Proxy = BL.null - take1_ = BL.uncons - takeN_ n s - | n <= 0 = Just (BL.empty, s) - | BL.null s = Nothing - | otherwise = Just (BL.splitAt (fromIntegral n) s) - takeWhile_ = BL.span - showTokens Proxy = stringPretty . fmap (chr . fromIntegral) +instance TraversableStream BL.ByteString where -- NOTE Do not eta-reduce these (breaks inlining) reachOffset o pst = - reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) o pst + reachOffset' splitAtBL BL.foldl' BL8.unpack (chr . fromIntegral) (10, 9) byteInc o pst reachOffsetNoLine o pst = - reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) o pst + reachOffsetNoLine' splitAtBL BL.foldl' (10, 9) byteInc o pst -instance Stream T.Text where - type Token T.Text = Char - type Tokens T.Text = T.Text - tokenToChunk Proxy = T.singleton - tokensToChunk Proxy = T.pack - chunkToTokens Proxy = T.unpack - chunkLength Proxy = T.length - chunkEmpty Proxy = T.null - take1_ = T.uncons - takeN_ n s - | n <= 0 = Just (T.empty, s) - | T.null s = Nothing - | otherwise = Just (T.splitAt n s) - takeWhile_ = T.span - showTokens Proxy = stringPretty +instance TraversableStream T.Text where -- NOTE Do not eta-reduce (breaks inlining of reachOffset'). reachOffset o pst = - reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') o pst + reachOffset' T.splitAt T.foldl' T.unpack id ('\n', '\t') charInc o pst reachOffsetNoLine o pst = - reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') o pst + reachOffsetNoLine' T.splitAt T.foldl' ('\n', '\t') charInc o pst -instance Stream TL.Text where - type Token TL.Text = Char - type Tokens TL.Text = TL.Text - tokenToChunk Proxy = TL.singleton - tokensToChunk Proxy = TL.pack - chunkToTokens Proxy = TL.unpack - chunkLength Proxy = fromIntegral . TL.length - chunkEmpty Proxy = TL.null - take1_ = TL.uncons - takeN_ n s - | n <= 0 = Just (TL.empty, s) - | TL.null s = Nothing - | otherwise = Just (TL.splitAt (fromIntegral n) s) - takeWhile_ = TL.span - showTokens Proxy = stringPretty +instance TraversableStream TL.Text where -- NOTE Do not eta-reduce (breaks inlining of reachOffset'). reachOffset o pst = - reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') o pst + reachOffset' splitAtTL TL.foldl' TL.unpack id ('\n', '\t') charInc o pst reachOffsetNoLine o pst = - reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') o pst + reachOffsetNoLine' splitAtTL TL.foldl' ('\n', '\t') charInc o pst ---------------------------------------------------------------------------- -- Helpers -- | An internal helper state type combining a difference 'String' and an -- unboxed 'SourcePos'. - -data St = St SourcePos ShowS +data St = St {-# UNPACK #-} !SourcePos ShowS -- | A helper definition to facilitate defining 'reachOffset' for various -- stream types. - +reachOffset' :: + forall s. + (Stream s) => + -- | How to split input stream at given offset + (Int -> s -> (Tokens s, s)) -> + -- | How to fold over input stream + (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) -> + -- | How to convert chunk of input stream into a 'String' + (Tokens s -> String) -> + -- | How to convert a token into a 'Char' + (Token s -> Char) -> + -- | Newline token and tab token + (Token s, Token s) -> + -- | Update column position for a token + (Token s -> Pos -> Pos) -> + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | Line at which 'SourcePos' is located, updated 'PosState' + (Maybe String, PosState s) reachOffset' - :: forall s. Stream s - => (Int -> s -> (Tokens s, s)) - -- ^ How to split input stream at given offset - -> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) - -- ^ How to fold over input stream - -> (Tokens s -> String) - -- ^ How to convert chunk of input stream into a 'String' - -> (Token s -> Char) - -- ^ How to convert a token into a 'Char' - -> (Token s, Token s) - -- ^ Newline token and tab token - -> Int - -- ^ Offset to reach - -> PosState s - -- ^ Initial 'PosState' to use - -> (String, PosState s) - -- ^ Line at which 'SourcePos' is located, updated 'PosState' -reachOffset' splitAt' - foldl'' - fromToks - fromTok - (newlineTok, tabTok) - o - PosState {..} = - ( case expandTab pstateTabWidth - . addPrefix - . f - . fromToks - . fst - $ takeWhile_ (/= newlineTok) post of - "" -> "" - xs -> xs - , PosState - { pstateInput = post - , pstateOffset = max pstateOffset o - , pstateSourcePos = spos - , pstateTabWidth = pstateTabWidth - , pstateLinePrefix = - if sameLine - -- NOTE We don't use difference lists here because it's - -- desirable for 'PosState' to be an instance of 'Eq' and - -- 'Show'. So we just do appending here. Fortunately several - -- parse errors on the same line should be relatively rare. - then pstateLinePrefix ++ f "" - else f "" - } - ) - where - addPrefix xs = - if sameLine - then pstateLinePrefix ++ xs - else xs - sameLine = sourceLine spos == sourceLine pstateSourcePos - (pre, post) = splitAt' (o - pstateOffset) pstateInput - St spos f = foldl'' go (St pstateSourcePos id) pre - go (St apos g) ch = - let SourcePos n l c = apos - c' = unPos c - w = unPos pstateTabWidth - in if | ch == newlineTok -> - St (SourcePos n (l <> pos1) pos1) - id - | ch == tabTok -> - St (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))) - (g . (fromTok ch :)) - | otherwise -> - St (SourcePos n l (c <> pos1)) - (g . (fromTok ch :)) + splitAt' + foldl'' + fromToks + fromTok + (newlineTok, tabTok) + columnIncrement + o + PosState {..} = + ( Just $ case expandTab pstateTabWidth + . addPrefix + . f + . fromToks + . fst + $ takeWhile_ (/= newlineTok) post of + "" -> "" + xs -> xs, + PosState + { pstateInput = post, + pstateOffset = max pstateOffset o, + pstateSourcePos = spos, + pstateTabWidth = pstateTabWidth, + pstateLinePrefix = + if sameLine + then -- NOTE We don't use difference lists here because it's + -- desirable for 'PosState' to be an instance of 'Eq' and + -- 'Show'. So we just do appending here. Fortunately several + -- parse errors on the same line should be relatively rare. + pstateLinePrefix ++ f "" + else f "" + } + ) + where + addPrefix xs = + if sameLine + then pstateLinePrefix ++ xs + else xs + sameLine = sourceLine spos == sourceLine pstateSourcePos + (pre, post) = splitAt' (o - pstateOffset) pstateInput + St spos f = foldl'' go (St pstateSourcePos id) pre + go (St apos g) ch = + let SourcePos n l c = apos + c' = unPos c + w = unPos pstateTabWidth + in if + | ch == newlineTok -> + St + (SourcePos n (l <> pos1) pos1) + id + | ch == tabTok -> + St + (SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w))) + (g . (fromTok ch :)) + | otherwise -> + St + (SourcePos n l (columnIncrement ch c)) + (g . (fromTok ch :)) {-# INLINE reachOffset' #-} -- | Like 'reachOffset'' but for 'reachOffsetNoLine'. - +reachOffsetNoLine' :: + forall s. + (Stream s) => + -- | How to split input stream at given offset + (Int -> s -> (Tokens s, s)) -> + -- | How to fold over input stream + (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) -> + -- | Newline token and tab token + (Token s, Token s) -> + -- | Update column position for a token + (Token s -> Pos -> Pos) -> + -- | Offset to reach + Int -> + -- | Initial 'PosState' to use + PosState s -> + -- | Updated 'PosState' + PosState s reachOffsetNoLine' - :: forall s. Stream s - => (Int -> s -> (Tokens s, s)) - -- ^ How to split input stream at given offset - -> (forall b. (b -> Token s -> b) -> b -> Tokens s -> b) - -- ^ How to fold over input stream - -> (Token s, Token s) - -- ^ Newline token and tab token - -> Int - -- ^ Offset to reach - -> PosState s - -- ^ Initial 'PosState' to use - -> PosState s - -- ^ Updated 'PosState' -reachOffsetNoLine' splitAt' - foldl'' - (newlineTok, tabTok) - o - PosState {..} = - ( PosState - { pstateInput = post - , pstateOffset = max pstateOffset o - , pstateSourcePos = spos - , pstateTabWidth = pstateTabWidth - , pstateLinePrefix = pstateLinePrefix - } - ) - where - spos = foldl'' go pstateSourcePos pre - (pre, post) = splitAt' (o - pstateOffset) pstateInput - go (SourcePos n l c) ch = - let c' = unPos c - w = unPos pstateTabWidth - in if | ch == newlineTok -> - SourcePos n (l <> pos1) pos1 - | ch == tabTok -> - SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)) - | otherwise -> - SourcePos n l (c <> pos1) + splitAt' + foldl'' + (newlineTok, tabTok) + columnIncrement + o + PosState {..} = + ( PosState + { pstateInput = post, + pstateOffset = max pstateOffset o, + pstateSourcePos = spos, + pstateTabWidth = pstateTabWidth, + pstateLinePrefix = pstateLinePrefix + } + ) + where + spos = foldl'' go pstateSourcePos pre + (pre, post) = splitAt' (o - pstateOffset) pstateInput + go (SourcePos n l c) ch = + let c' = unPos c + w = unPos pstateTabWidth + in if + | ch == newlineTok -> + SourcePos n (l <> pos1) pos1 + | ch == tabTok -> + SourcePos n l (mkPos $ c' + w - ((c' - 1) `rem` w)) + | otherwise -> + SourcePos n l (columnIncrement ch c) {-# INLINE reachOffsetNoLine' #-} -- | Like 'BL.splitAt' but accepts the index as an 'Int'. - splitAtBL :: Int -> BL.ByteString -> (BL.ByteString, BL.ByteString) splitAtBL n = BL.splitAt (fromIntegral n) {-# INLINE splitAtBL #-} -- | Like 'TL.splitAt' but accepts the index as an 'Int'. - splitAtTL :: Int -> TL.Text -> (TL.Text, TL.Text) splitAtTL n = TL.splitAt (fromIntegral n) {-# INLINE splitAtTL #-} -- | @stringPretty s@ returns pretty representation of string @s@. This is -- used when printing string tokens in error messages. - stringPretty :: NonEmpty Char -> String -stringPretty (x:|[]) = charPretty x -stringPretty ('\r':|"\n") = "crlf newline" -stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\"" +stringPretty (x :| []) = charPretty x +stringPretty ('\r' :| "\n") = "crlf newline" +stringPretty xs = "\"" <> concatMap f (NE.toList xs) <> "\"" where f ch = case charPretty' ch of - Nothing -> [ch] + Nothing -> [ch] Just pretty -> "<" <> pretty <> ">" -- | @charPretty ch@ returns user-friendly string representation of given -- character @ch@, suitable for using in error messages. - charPretty :: Char -> String charPretty ' ' = "space" charPretty ch = fromMaybe ("'" <> [ch] <> "'") (charPretty' ch) -- | If the given character has a pretty representation, return that, -- otherwise 'Nothing'. This is an internal helper. - charPretty' :: Char -> Maybe String charPretty' = \case '\NUL' -> Just "null" @@ -471,14 +724,14 @@ '\ENQ' -> Just "enquiry" '\ACK' -> Just "acknowledge" '\BEL' -> Just "bell" - '\BS' -> Just "backspace" - '\t' -> Just "tab" - '\n' -> Just "newline" - '\v' -> Just "vertical tab" - '\f' -> Just "form feed" - '\r' -> Just "carriage return" - '\SO' -> Just "shift out" - '\SI' -> Just "shift in" + '\BS' -> Just "backspace" + '\t' -> Just "tab" + '\n' -> Just "newline" + '\v' -> Just "vertical tab" + '\f' -> Just "form feed" + '\r' -> Just "carriage return" + '\SO' -> Just "shift out" + '\SI' -> Just "shift in" '\DLE' -> Just "data link escape" '\DC1' -> Just "device control one" '\DC2' -> Just "device control two" @@ -488,27 +741,39 @@ '\SYN' -> Just "synchronous idle" '\ETB' -> Just "end of transmission block" '\CAN' -> Just "cancel" - '\EM' -> Just "end of medium" + '\EM' -> Just "end of medium" '\SUB' -> Just "substitute" '\ESC' -> Just "escape" - '\FS' -> Just "file separator" - '\GS' -> Just "group separator" - '\RS' -> Just "record separator" - '\US' -> Just "unit separator" + '\FS' -> Just "file separator" + '\GS' -> Just "group separator" + '\RS' -> Just "record separator" + '\US' -> Just "unit separator" '\DEL' -> Just "delete" '\160' -> Just "non-breaking space" - _ -> Nothing + _ -> Nothing -- | Replace tab characters with given number of spaces. - -expandTab - :: Pos - -> String - -> String -expandTab w' = go 0 +expandTab :: + Pos -> + String -> + String +expandTab w' = go 0 0 where - go 0 [] = [] - go 0 ('\t':xs) = go w xs - go 0 (x:xs) = x : go 0 xs - go n xs = ' ' : go (n - 1) xs - w = unPos w' + go _ 0 [] = [] + go !i 0 ('\t' : xs) = go i (w - (i `rem` w)) xs + go !i 0 (x : xs) = x : go (i + 1) 0 xs + go !i n xs = ' ' : go (i + 1) (n - 1) xs + w = unPos w' + +-- | Return updated column position that corresponds to the given 'Char'. +charInc :: Char -> Pos -> Pos +charInc ch c + | Unicode.isZeroWidthChar ch = c + | Unicode.isWideChar ch = c <> pos1 <> pos1 + | otherwise = c <> pos1 + +-- | Return updated column position that corresponds to the given 'Word8'. +byteInc :: Word8 -> Pos -> Pos +byteInc w c + | w < 0x20 || (w >= 0x7f && w < 0xa0) = c -- C0 and C1 control chars + | otherwise = c <> pos1 diff --git a/Text/Megaparsec/Unicode.hs b/Text/Megaparsec/Unicode.hs new file mode 100644 --- /dev/null +++ b/Text/Megaparsec/Unicode.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Module : Text.Megaparsec.Unicode +-- Copyright : © 2024–present Megaparsec contributors +-- License : FreeBSD +-- +-- Maintainer : Mark Karpov +-- Stability : experimental +-- Portability : portable +-- +-- Utility functions for working with Unicode. +-- +-- @since 9.7.0 +module Text.Megaparsec.Unicode + ( stringLength, + charLength, + isWideChar, + isZeroWidthChar, + ) +where + +import Data.Array (Array, bounds, listArray, (!)) +import Data.Char (ord) + +-- | Calculate length of a string taking into account the fact that certain +-- 'Char's may span more than 1 column. +-- +-- @since 9.7.0 +stringLength :: (Traversable t) => t Char -> Int +stringLength = sum . fmap charLength + +-- | Return length of an individual 'Char'. +-- +-- @since 9.7.0 +charLength :: Char -> Int +charLength ch + | isZeroWidthChar ch = 0 + | isWideChar ch = 2 + | otherwise = 1 + +-- | Determine whether the given 'Char' is “wide”, that is, whether it spans +-- 2 columns instead of one. +-- +-- @since 9.7.0 +isWideChar :: Char -> Bool +isWideChar c = go (bounds wideCharRanges) + where + go (lo, hi) + | hi < lo = False + | a <= n && n <= b = True + | n < a = go (lo, pred mid) + | otherwise = go (succ mid, hi) + where + mid = (lo + hi) `div` 2 + (a, b) = wideCharRanges ! mid + n = ord c + +-- | Determine whether the given 'Char' is "zero-width", that is, whether it +-- has no visible representation and does not advance the cursor position. +-- This includes control characters and certain Unicode zero-width characters. +-- +-- @since 9.8.0 +isZeroWidthChar :: Char -> Bool +isZeroWidthChar c = go (bounds zeroWidthCharRanges) + where + go (lo, hi) + | hi < lo = False + | a <= n && n <= b = True + | n < a = go (lo, pred mid) + | otherwise = go (succ mid, hi) + where + mid = (lo + hi) `div` 2 + (a, b) = zeroWidthCharRanges ! mid + n = ord c + +-- | Wide character ranges. +wideCharRanges :: Array Int (Int, Int) +wideCharRanges = + listArray + (0, 118) + [ (0x001100, 0x00115f), + (0x00231a, 0x00231b), + (0x002329, 0x00232a), + (0x0023e9, 0x0023ec), + (0x0023f0, 0x0023f0), + (0x0023f3, 0x0023f3), + (0x0025fd, 0x0025fe), + (0x002614, 0x002615), + (0x002648, 0x002653), + (0x00267f, 0x00267f), + (0x002693, 0x002693), + (0x0026a1, 0x0026a1), + (0x0026aa, 0x0026ab), + (0x0026bd, 0x0026be), + (0x0026c4, 0x0026c5), + (0x0026ce, 0x0026ce), + (0x0026d4, 0x0026d4), + (0x0026ea, 0x0026ea), + (0x0026f2, 0x0026f3), + (0x0026f5, 0x0026f5), + (0x0026fa, 0x0026fa), + (0x0026fd, 0x0026fd), + (0x002705, 0x002705), + (0x00270a, 0x00270b), + (0x002728, 0x002728), + (0x00274c, 0x00274c), + (0x00274e, 0x00274e), + (0x002753, 0x002755), + (0x002757, 0x002757), + (0x002795, 0x002797), + (0x0027b0, 0x0027b0), + (0x0027bf, 0x0027bf), + (0x002b1b, 0x002b1c), + (0x002b50, 0x002b50), + (0x002b55, 0x002b55), + (0x002e80, 0x002e99), + (0x002e9b, 0x002ef3), + (0x002f00, 0x002fd5), + (0x002ff0, 0x002ffb), + (0x003000, 0x00303e), + (0x003041, 0x003096), + (0x003099, 0x0030ff), + (0x003105, 0x00312f), + (0x003131, 0x00318e), + (0x003190, 0x0031ba), + (0x0031c0, 0x0031e3), + (0x0031f0, 0x00321e), + (0x003220, 0x003247), + (0x003250, 0x004db5), + (0x004e00, 0x009fef), + (0x00a000, 0x00a48c), + (0x00a490, 0x00a4c6), + (0x00a960, 0x00a97c), + (0x00ac00, 0x00d7a3), + (0x00f900, 0x00fa6d), + (0x00fa70, 0x00fad9), + (0x00fe10, 0x00fe19), + (0x00fe30, 0x00fe52), + (0x00fe54, 0x00fe66), + (0x00fe68, 0x00fe6b), + (0x00ff01, 0x00ff60), + (0x00ffe0, 0x00ffe6), + (0x016fe0, 0x016fe3), + (0x017000, 0x0187f7), + (0x018800, 0x018af2), + (0x01b000, 0x01b11e), + (0x01b150, 0x01b152), + (0x01b164, 0x01b167), + (0x01b170, 0x01b2fb), + (0x01f004, 0x01f004), + (0x01f0cf, 0x01f0cf), + (0x01f18e, 0x01f18e), + (0x01f191, 0x01f19a), + (0x01f200, 0x01f202), + (0x01f210, 0x01f23b), + (0x01f240, 0x01f248), + (0x01f250, 0x01f251), + (0x01f260, 0x01f265), + (0x01f300, 0x01f320), + (0x01f32d, 0x01f335), + (0x01f337, 0x01f37c), + (0x01f37e, 0x01f393), + (0x01f3a0, 0x01f3ca), + (0x01f3cf, 0x01f3d3), + (0x01f3e0, 0x01f3f0), + (0x01f3f4, 0x01f3f4), + (0x01f3f8, 0x01f43e), + (0x01f440, 0x01f440), + (0x01f442, 0x01f4fc), + (0x01f4ff, 0x01f53d), + (0x01f54b, 0x01f54e), + (0x01f550, 0x01f567), + (0x01f57a, 0x01f57a), + (0x01f595, 0x01f596), + (0x01f5a4, 0x01f5a4), + (0x01f5fb, 0x01f64f), + (0x01f680, 0x01f6c5), + (0x01f6cc, 0x01f6cc), + (0x01f6d0, 0x01f6d2), + (0x01f6d5, 0x01f6d5), + (0x01f6eb, 0x01f6ec), + (0x01f6f4, 0x01f6fa), + (0x01f7e0, 0x01f7eb), + (0x01f90d, 0x01f971), + (0x01f973, 0x01f976), + (0x01f97a, 0x01f9a2), + (0x01f9a5, 0x01f9aa), + (0x01f9ae, 0x01f9ca), + (0x01f9cd, 0x01f9ff), + (0x01fa70, 0x01fa73), + (0x01fa78, 0x01fa7a), + (0x01fa80, 0x01fa82), + (0x01fa90, 0x01fa95), + (0x020000, 0x02a6d6), + (0x02a700, 0x02b734), + (0x02b740, 0x02b81d), + (0x02b820, 0x02cea1), + (0x02ceb0, 0x02ebe0), + (0x02f800, 0x02fa1d) + ] +{-# NOINLINE wideCharRanges #-} + +-- | Zero-width character ranges. +zeroWidthCharRanges :: Array Int (Int, Int) +zeroWidthCharRanges = + listArray + (0, 12) + [ (0x0000, 0x001f), -- C0 control characters + (0x007f, 0x009f), -- DEL and C1 control characters + (0x00ad, 0x00ad), -- Soft Hyphen + (0x0300, 0x036f), -- Combining Diacritical Marks + (0x0483, 0x0489), -- Combining Cyrillic + (0x0591, 0x05bd), -- Hebrew combining marks + (0x05bf, 0x05bf), -- Hebrew point + (0x05c1, 0x05c2), -- Hebrew points + (0x05c4, 0x05c5), -- Hebrew marks + (0x05c7, 0x05c7), -- Hebrew point + (0x0610, 0x061a), -- Arabic combining marks + (0x200b, 0x200f), -- Zero width chars and directional marks + (0x202a, 0x202e) -- Directional formatting + ] +{-# NOINLINE zeroWidthCharRanges #-} diff --git a/bench/memory/Main.hs b/bench/memory/Main.hs --- a/bench/memory/Main.hs +++ b/bench/memory/Main.hs @@ -1,51 +1,51 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E import Data.Text (Text) +import qualified Data.Text as T import Data.Void import Text.Megaparsec +import qualified Text.Megaparsec.Byte.Binary as Binary import Text.Megaparsec.Char -import Weigh -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L - -#if !MIN_VERSION_base(4,13,0) -import Data.Semigroup ((<>)) -#endif - --- | The type of parser that consumes 'String's. +import Weigh +-- | The type of parser that consumes 'Text'. type Parser = Parsec Void Text +-- | The type of parser that consumes 'ByteString'. +type ParserBs = Parsec Void ByteString + main :: IO () main = mainWith $ do setColumns [Case, Allocated, GCs, Max] - bparser "string" manyAs (string . fst) - bparser "string'" manyAs (string' . fst) - bparser "many" manyAs (const $ many (char 'a')) - bparser "some" manyAs (const $ some (char 'a')) - bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd) - bparser "count" manyAs (\(_,n) -> count n (char 'a')) - bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a')) - bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) - bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) + bparser "string" manyAs (string . fst) + bparser "string'" manyAs (string' . fst) + bparser "many" manyAs (const $ many (char 'a')) + bparser "some" manyAs (const $ some (char 'a')) + bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd) + bparser "count" manyAs (\(_, n) -> count n (char 'a')) + bparser "count'" manyAs (\(_, n) -> count' 1 n (char 'a')) + bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) + bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')) - bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) - bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) - bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) + bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) + bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) + bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) bparser "skipMany" manyAs (const $ skipMany (char 'a')) bparser "skipSome" manyAs (const $ skipSome (char 'a')) - bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a')) + bparser "skipCount" manyAs (\(_, n) -> skipCount n (char 'a')) bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')) @@ -54,13 +54,15 @@ bparser "octal" mkInt (const (L.octal :: Parser Integer)) bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)) bparser "scientific" mkInt (const L.scientific) + bparserBs "word32be" many0x33 (const $ many Binary.word32be) + bparserBs "word32le" many0x33 (const $ many Binary.word32le) forM_ stdSeries $ \n -> bbundle "single error" n [n] bbundle "2 errors" 1000 [1, 1000] bbundle "4 errors" 1000 [1, 500, 1000] - bbundle "100 errors" 1000 [10,20..1000] + bbundle "100 errors" 1000 [10, 20 .. 1000] breachOffset 0 1000 breachOffset 0 2000 @@ -73,123 +75,153 @@ breachOffsetNoLine 1000 1000 -- | Perform a series of measurements with the same parser. - -bparser :: NFData a - => String -- ^ Name of the benchmark group - -> (Int -> Text) -- ^ How to construct input - -> ((Text, Int) -> Parser a) -- ^ The parser receiving its future input - -> Weigh () +bparser :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> Text) -> + -- | The parser receiving its future input + ((Text, Int) -> Parser a) -> + Weigh () bparser name f p = forM_ stdSeries $ \i -> do - let arg = (f i,i) - p' (s,n) = parse (p (s,n)) "" s + let arg = (f i, i) + p' (s, n) = parse (p (s, n)) "" s func (name ++ "-" ++ show i) p' arg --- | Bench the 'errorBundlePretty' function. +-- | Perform a series of measurements with the same parser. +bparserBs :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> ByteString) -> + -- | The parser receiving its future input + ((ByteString, Int) -> ParserBs a) -> + Weigh () +bparserBs name f p = forM_ stdSeries $ \i -> do + let arg = (f i, i) + p' (s, n) = parse (p (s, n)) "" s + func (name ++ "-" ++ show i) p' arg -bbundle - :: String -- ^ Name of the benchmark - -> Int -- ^ Number of lines in input stream - -> [Int] -- ^ Lines with parse errors - -> Weigh () +-- | Benchmark the 'errorBundlePretty' function. +bbundle :: + -- | Name of the benchmark + String -> + -- | Number of lines in input stream + Int -> + -- | Lines with parse errors + [Int] -> + Weigh () bbundle name totalLines sps = do let s = take (totalLines * 80) (cycle as) as = replicate 79 'a' ++ "\n" - f l = TrivialError - (20 + l * 80) - (Just $ Tokens ('a' :| "")) - (E.singleton $ Tokens ('b' :| "")) + f l = + TrivialError + (20 + l * 80) + (Just $ Tokens ('a' :| "")) + (E.singleton $ Tokens ('b' :| "")) bundle :: ParseErrorBundle String Void - bundle = ParseErrorBundle - { bundleErrors = f <$> NE.fromList sps - , bundlePosState = PosState - { pstateInput = s - , pstateOffset = 0 - , pstateSourcePos = initialPos "" - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" + bundle = + ParseErrorBundle + { bundleErrors = f <$> NE.fromList sps, + bundlePosState = + PosState + { pstateInput = s, + pstateOffset = 0, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } } - } - func ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name) - errorBundlePretty - bundle - --- | Bench the 'reachOffset' function. + func + ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name) + errorBundlePretty + bundle -breachOffset - :: Int -- ^ Starting offset in 'PosState' - -> Int -- ^ Offset to reach - -> Weigh () -breachOffset o0 o1 = func - ("reachOffset-" ++ show o0 ++ "-" ++ show o1) - f - (o0 * 80, o1 * 80) +-- | Benchmark the 'reachOffset' function. +breachOffset :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Weigh () +breachOffset o0 o1 = + func + ("reachOffset-" ++ show o0 ++ "-" ++ show o1) + f + (o0 * 80, o1 * 80) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) = - snd $ reachOffset targetOffset PosState - { pstateInput = manyAs (targetOffset - startOffset) - , pstateOffset = startOffset - , pstateSourcePos = initialPos "" - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } - --- | Bench the 'reachOffsetNoLine' function. + snd $ + reachOffset + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } -breachOffsetNoLine - :: Int -- ^ Starting offset in 'PosState' - -> Int -- ^ Offset to reach - -> Weigh () -breachOffsetNoLine o0 o1 = func - ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1) - f - (o0 * 80, o1 * 80) +-- | Benchmark the 'reachOffsetNoLine' function. +breachOffsetNoLine :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Weigh () +breachOffsetNoLine o0 o1 = + func + ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1) + f + (o0 * 80, o1 * 80) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) = - reachOffsetNoLine targetOffset PosState - { pstateInput = manyAs (targetOffset - startOffset) - , pstateOffset = startOffset - , pstateSourcePos = initialPos "" - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } + reachOffsetNoLine + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } -- | The series of sizes to try as part of 'bparser'. - stdSeries :: [Int] -stdSeries = [500,1000,2000,4000] +stdSeries = [500, 1000, 2000, 4000] ---------------------------------------------------------------------------- -- Helpers -- | Generate that many \'a\' characters. - manyAs :: Int -> Text manyAs n = T.replicate n "a" --- | Like 'manyAs', but interspersed with \'b\'s. +-- | Like 'manyAs' but the result is a 'ByteString'. +many0x33 :: Int -> ByteString +many0x33 n = B.replicate n 0x33 +-- | Like 'manyAs', but interspersed with \'b\'s. manyAbs :: Int -> Text manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab") -- | Like 'manyAs', but with a \'b\' added to the end. - manyAsB :: Int -> Text manyAsB n = manyAs n <> "b" -- | Like 'manyAsB', but returns a 'String'. - manyAsB' :: Int -> String manyAsB' n = replicate n 'a' ++ "b" -- | Like 'manyAbs', but ends in a \'b\'. - manyAbs' :: Int -> Text manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab") -- | Render an 'Integer' with the number of digits linearly dependent on the -- argument. - mkInt :: Int -> Text mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100)) diff --git a/bench/speed/Main.hs b/bench/speed/Main.hs --- a/bench/speed/Main.hs +++ b/bench/speed/Main.hs @@ -1,191 +1,221 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where import Control.DeepSeq import Criterion.Main +import Data.ByteString (ByteString) +import qualified Data.ByteString as B import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import qualified Data.Set as E import Data.Text (Text) +import qualified Data.Text as T import Data.Void import Text.Megaparsec +import qualified Text.Megaparsec.Byte.Binary as Binary import Text.Megaparsec.Char -import qualified Data.List.NonEmpty as NE -import qualified Data.Set as E -import qualified Data.Text as T import qualified Text.Megaparsec.Char.Lexer as L -#if !MIN_VERSION_base(4,13,0) -import Data.Semigroup ((<>)) -#endif - --- | The type of parser that consumes 'String's. - +-- | The type of parser that consumes 'Text'. type Parser = Parsec Void Text -main :: IO () -main = defaultMain - [ bparser "string" manyAs (string . fst) - , bparser "string'" manyAs (string' . fst) - , bparser "many" manyAs (const $ many (char 'a')) - , bparser "some" manyAs (const $ some (char 'a')) - , bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd) - , bparser "count" manyAs (\(_,n) -> count n (char 'a')) - , bparser "count'" manyAs (\(_,n) -> count' 1 n (char 'a')) - , bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')) - , bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')) - , bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')) - , bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')) - , bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')) - , bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')) - , bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')) - , bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')) - , bparser "skipMany" manyAs (const $ skipMany (char 'a')) - , bparser "skipSome" manyAs (const $ skipSome (char 'a')) - , bparser "skipCount" manyAs (\(_,n) -> skipCount n (char 'a')) - , bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')) - , bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')) - , bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')) - , bparser "takeWhile1P" manyAs (const $ takeWhile1P Nothing (== 'a')) - , bparser "decimal" mkInt (const (L.decimal :: Parser Integer)) - , bparser "octal" mkInt (const (L.octal :: Parser Integer)) - , bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)) - , bparser "scientific" mkInt (const L.scientific) - - , bgroup "" [bbundle "single error" n [n] | n <- stdSeries] - - , bbundle "2 errors" 1000 [1, 1000] - , bbundle "4 errors" 1000 [1, 500, 1000] - , bbundle "100 errors" 1000 [10,20..1000] - - , breachOffset 0 1000 - , breachOffset 0 2000 - , breachOffset 0 4000 - , breachOffset 1000 1000 - - , breachOffsetNoLine 0 1000 - , breachOffsetNoLine 0 2000 - , breachOffsetNoLine 0 4000 - , breachOffsetNoLine 1000 1000 +-- | The type of parser that consumes 'ByteString'. +type ParserBs = Parsec Void ByteString - ] +main :: IO () +main = + defaultMain + [ bparser "string" manyAs (string . fst), + bparser "string'" manyAs (string' . fst), + bparser "many" manyAs (const $ many (char 'a')), + bparser "some" manyAs (const $ some (char 'a')), + bparser "choice" (const "b") (choice . fmap char . manyAsB' . snd), + bparser "count" manyAs (\(_, n) -> count n (char 'a')), + bparser "count'" manyAs (\(_, n) -> count' 1 n (char 'a')), + bparser "endBy" manyAbs' (const $ endBy (char 'a') (char 'b')), + bparser "endBy1" manyAbs' (const $ endBy1 (char 'a') (char 'b')), + bparser "manyTill" manyAsB (const $ manyTill (char 'a') (char 'b')), + bparser "someTill" manyAsB (const $ someTill (char 'a') (char 'b')), + bparser "sepBy" manyAbs (const $ sepBy (char 'a') (char 'b')), + bparser "sepBy1" manyAbs (const $ sepBy1 (char 'a') (char 'b')), + bparser "sepEndBy" manyAbs' (const $ sepEndBy (char 'a') (char 'b')), + bparser "sepEndBy1" manyAbs' (const $ sepEndBy1 (char 'a') (char 'b')), + bparser "skipMany" manyAs (const $ skipMany (char 'a')), + bparser "skipSome" manyAs (const $ skipSome (char 'a')), + bparser "skipCount" manyAs (\(_, n) -> skipCount n (char 'a')), + bparser "skipManyTill" manyAsB (const $ skipManyTill (char 'a') (char 'b')), + bparser "skipSomeTill" manyAsB (const $ skipSomeTill (char 'a') (char 'b')), + bparser "takeWhileP" manyAs (const $ takeWhileP Nothing (== 'a')), + bparser "takeWhile1P" manyAs (const $ takeWhile1P Nothing (== 'a')), + bparser "decimal" mkInt (const (L.decimal :: Parser Integer)), + bparser "octal" mkInt (const (L.octal :: Parser Integer)), + bparser "hexadecimal" mkInt (const (L.hexadecimal :: Parser Integer)), + bparser "scientific" mkInt (const L.scientific), + bparserBs "word32be" many0x33 (const $ many Binary.word32be), + bparserBs "word32le" many0x33 (const $ many Binary.word32le), + bgroup "" [bbundle "single error" n [n] | n <- stdSeries], + bbundle "2 errors" 1000 [1, 1000], + bbundle "4 errors" 1000 [1, 500, 1000], + bbundle "100 errors" 1000 [10, 20 .. 1000], + breachOffset 0 1000, + breachOffset 0 2000, + breachOffset 0 4000, + breachOffset 1000 1000, + breachOffsetNoLine 0 1000, + breachOffsetNoLine 0 2000, + breachOffsetNoLine 0 4000, + breachOffsetNoLine 1000 1000 + ] -- | Perform a series to measurements with the same parser. - -bparser :: NFData a - => String -- ^ Name of the benchmark group - -> (Int -> Text) -- ^ How to construct input - -> ((Text, Int) -> Parser a) -- ^ The parser receiving its future input - -> Benchmark -- ^ The benchmark +bparser :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> Text) -> + -- | The parser receiving its future input + ((Text, Int) -> Parser a) -> + -- | The benchmark + Benchmark bparser name f p = bgroup name (bs <$> stdSeries) where bs n = env (return (f n, n)) (bench (show n) . nf p') - p' (s,n) = parse (p (s,n)) "" s + p' (s, n) = parse (p (s, n)) "" s --- | Bench the 'errorBundlePretty' function. +-- | Perform a series to measurements with the same parser. +bparserBs :: + (NFData a) => + -- | Name of the benchmark group + String -> + -- | How to construct input + (Int -> ByteString) -> + -- | The parser receiving its future input + ((ByteString, Int) -> ParserBs a) -> + -- | The benchmark + Benchmark +bparserBs name f p = bgroup name (bs <$> stdSeries) + where + bs n = env (return (f n, n)) (bench (show n) . nf p') + p' (s, n) = parse (p (s, n)) "" s -bbundle - :: String -- ^ Name of the benchmark - -> Int -- ^ Number of lines in input stream - -> [Int] -- ^ Lines with parse errors - -> Benchmark +-- | Benchmark the 'errorBundlePretty' function. +bbundle :: + -- | Name of the benchmark + String -> + -- | Number of lines in input stream + Int -> + -- | Lines with parse errors + [Int] -> + Benchmark bbundle name totalLines sps = let s = take (totalLines * 80) (cycle as) as = replicate 79 'a' ++ "\n" - f l = TrivialError - (20 + l * 80) - (Just $ Tokens ('a' :| "")) - (E.singleton $ Tokens ('b' :| "")) + f l = + TrivialError + (20 + l * 80) + (Just $ Tokens ('a' :| "")) + (E.singleton $ Tokens ('b' :| "")) bundle :: ParseErrorBundle String Void - bundle = ParseErrorBundle - { bundleErrors = f <$> NE.fromList sps - , bundlePosState = PosState - { pstateInput = s - , pstateOffset = 0 - , pstateSourcePos = initialPos "" - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" + bundle = + ParseErrorBundle + { bundleErrors = f <$> NE.fromList sps, + bundlePosState = + PosState + { pstateInput = s, + pstateOffset = 0, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } } - } - in bench ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name) - (nf errorBundlePretty bundle) - --- | Bench the 'reachOffset' function. + in bench + ("errorBundlePretty-" ++ show totalLines ++ "-" ++ name) + (nf errorBundlePretty bundle) -breachOffset - :: Int -- ^ Starting offset in 'PosState' - -> Int -- ^ Offset to reach - -> Benchmark -breachOffset o0 o1 = bench - ("reachOffset-" ++ show o0 ++ "-" ++ show o1) - (nf f (o0 * 80, o1 * 80)) +-- | Benchmark the 'reachOffset' function. +breachOffset :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Benchmark +breachOffset o0 o1 = + bench + ("reachOffset-" ++ show o0 ++ "-" ++ show o1) + (nf f (o0 * 80, o1 * 80)) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) = - snd $ reachOffset targetOffset PosState - { pstateInput = manyAs (targetOffset - startOffset) - , pstateOffset = startOffset - , pstateSourcePos = initialPos "" - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } - --- | Bench the 'reachOffsetNoLine' function. + snd $ + reachOffset + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } -breachOffsetNoLine - :: Int -- ^ Starting offset in 'PosState' - -> Int -- ^ Offset to reach - -> Benchmark -breachOffsetNoLine o0 o1 = bench - ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1) - (nf f (o0 * 80, o1 * 80)) +-- | Benchmark the 'reachOffsetNoLine' function. +breachOffsetNoLine :: + -- | Starting offset in 'PosState' + Int -> + -- | Offset to reach + Int -> + Benchmark +breachOffsetNoLine o0 o1 = + bench + ("reachOffsetNoLine-" ++ show o0 ++ "-" ++ show o1) + (nf f (o0 * 80, o1 * 80)) where f :: (Int, Int) -> PosState Text f (startOffset, targetOffset) = - reachOffsetNoLine targetOffset PosState - { pstateInput = manyAs (targetOffset - startOffset) - , pstateOffset = startOffset - , pstateSourcePos = initialPos "" - , pstateTabWidth = defaultTabWidth - , pstateLinePrefix = "" - } + reachOffsetNoLine + targetOffset + PosState + { pstateInput = manyAs (targetOffset - startOffset), + pstateOffset = startOffset, + pstateSourcePos = initialPos "", + pstateTabWidth = defaultTabWidth, + pstateLinePrefix = "" + } -- | The series of sizes to try as part of 'bparser'. - stdSeries :: [Int] -stdSeries = [500,1000,2000,4000] +stdSeries = [500, 1000, 2000, 4000] ---------------------------------------------------------------------------- -- Helpers -- | Generate that many \'a\' characters. - manyAs :: Int -> Text manyAs n = T.replicate n "a" --- | Like 'manyAs', but interspersed with \'b\'s. +-- | Like 'manyAs' but the result is a 'ByteString'. +many0x33 :: Int -> ByteString +many0x33 n = B.replicate n 0x33 +-- | Like 'manyAs', but interspersed with \'b\'s. manyAbs :: Int -> Text manyAbs n = T.take (if even n then n + 1 else n) (T.replicate n "ab") -- | Like 'manyAs', but with a \'b\' added to the end. - manyAsB :: Int -> Text manyAsB n = manyAs n <> "b" -- | Like 'manyAsB', but returns a 'String'. - manyAsB' :: Int -> String manyAsB' n = replicate n 'a' ++ "b" -- | Like 'manyAbs', but ends in a \'b\'. - manyAbs' :: Int -> Text manyAbs' n = T.take (if even n then n else n + 1) (T.replicate n "ab") -- | Render an 'Integer' with the number of digits linearly dependent on the -- argument. - mkInt :: Int -> Text mkInt n = (T.pack . show) ((10 :: Integer) ^ (n `quot` 100)) diff --git a/megaparsec.cabal b/megaparsec.cabal --- a/megaparsec.cabal +++ b/megaparsec.cabal @@ -1,102 +1,127 @@ -name: megaparsec -version: 8.0.0 -cabal-version: 1.18 -tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 -license: BSD2 -license-file: LICENSE.md -author: Megaparsec contributors, - Paolo Martini , - Daan Leijen +cabal-version: 2.4 +name: megaparsec +version: 9.8.1 +license: BSD-2-Clause +license-file: LICENSE.md +maintainer: Mark Karpov +author: + Megaparsec contributors, + Paolo Martini , + Daan Leijen -maintainer: Mark Karpov -homepage: https://github.com/mrkkrp/megaparsec -bug-reports: https://github.com/mrkkrp/megaparsec/issues -category: Parsing -synopsis: Monadic parser combinators -build-type: Simple -description: +tested-with: + ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1 - This is an industrial-strength monadic parser combinator library. - Megaparsec is a feature-rich package that tries to find a nice balance - between speed, flexibility, and quality of parse errors. +homepage: https://github.com/mrkkrp/megaparsec +bug-reports: https://github.com/mrkkrp/megaparsec/issues +synopsis: Monadic parser combinators +description: + This is an industrial-strength monadic parser combinator library. + Megaparsec is a feature-rich package that tries to find a nice balance + between speed, flexibility, and quality of parse errors. -extra-doc-files: CHANGELOG.md - , README.md +category: Parsing +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md source-repository head - type: git - location: https://github.com/mrkkrp/megaparsec.git + type: git + location: https://github.com/mrkkrp/megaparsec.git flag dev - description: Turn on development settings. - manual: True - default: False + description: Turn on development settings. + default: False + manual: True library - build-depends: base >= 4.11 && < 5.0 - , bytestring >= 0.2 && < 0.11 - , case-insensitive >= 1.2 && < 1.3 - , containers >= 0.5 && < 0.7 - , deepseq >= 1.3 && < 1.5 - , mtl >= 2.2.2 && < 3.0 - , parser-combinators >= 1.0 && < 2.0 - , scientific >= 0.3.1 && < 0.4 - , text >= 0.2 && < 1.3 - , transformers >= 0.4 && < 0.6 - exposed-modules: Text.Megaparsec - , Text.Megaparsec.Byte - , Text.Megaparsec.Byte.Lexer - , Text.Megaparsec.Char - , Text.Megaparsec.Char.Lexer - , Text.Megaparsec.Debug - , Text.Megaparsec.Error - , Text.Megaparsec.Error.Builder - , Text.Megaparsec.Internal - , Text.Megaparsec.Pos - , Text.Megaparsec.Stream - other-modules: Text.Megaparsec.Class - , Text.Megaparsec.Common - , Text.Megaparsec.Lexer - , Text.Megaparsec.State - if flag(dev) - ghc-options: -O0 -Wall -Werror - else - ghc-options: -O2 -Wall - if flag(dev) - ghc-options: -Wcompat - -Wincomplete-record-updates - -Wincomplete-uni-patterns - -Wnoncanonical-monad-instances - default-language: Haskell2010 + exposed-modules: + Text.Megaparsec + Text.Megaparsec.Byte + Text.Megaparsec.Byte.Binary + Text.Megaparsec.Byte.Lexer + Text.Megaparsec.Char + Text.Megaparsec.Char.Lexer + Text.Megaparsec.Debug + Text.Megaparsec.Error + Text.Megaparsec.Error.Builder + Text.Megaparsec.Internal + Text.Megaparsec.Pos + Text.Megaparsec.State + Text.Megaparsec.Stream + Text.Megaparsec.Unicode + other-modules: + Text.Megaparsec.Class + Text.Megaparsec.Common + Text.Megaparsec.Lexer + + default-language: Haskell2010 + build-depends: + array >=0.5.3 && <0.6, + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + case-insensitive >=1.2 && <1.3, + containers >=0.5 && <0.9, + deepseq >=1.3 && <1.6, + mtl >=2.2.2 && <3, + parser-combinators >=1.0 && <2, + scientific >=0.3.7 && <0.4, + text >=0.2 && <2.2, + transformers >=0.4 && <0.7 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + + if impl(ghc >=9.8) + ghc-options: -Wno-x-partial + benchmark bench-speed - main-is: Main.hs - hs-source-dirs: bench/speed - type: exitcode-stdio-1.0 - build-depends: base >= 4.11 && < 5.0 - , containers >= 0.5 && < 0.7 - , criterion >= 0.6.2.1 && < 1.6 - , deepseq >= 1.3 && < 1.5 - , megaparsec - , text >= 0.2 && < 1.3 - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/speed + default-language: Haskell2010 + build-depends: + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + containers >=0.5 && <0.9, + criterion >=0.6.2.1 && <1.7, + deepseq >=1.3 && <1.6, + megaparsec, + text >=0.2 && <2.2 + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall + benchmark bench-memory - main-is: Main.hs - hs-source-dirs: bench/memory - type: exitcode-stdio-1.0 - build-depends: base >= 4.11 && < 5.0 - , containers >= 0.5 && < 0.7 - , deepseq >= 1.3 && < 1.5 - , megaparsec - , text >= 0.2 && < 1.3 - , weigh >= 0.0.4 - if flag(dev) - ghc-options: -O2 -Wall -Werror - else - ghc-options: -O2 -Wall - default-language: Haskell2010 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: bench/memory + default-language: Haskell2010 + build-depends: + base >=4.18 && <5, + bytestring >=0.2 && <0.13, + containers >=0.5 && <0.9, + deepseq >=1.3 && <1.6, + megaparsec, + text >=0.2 && <2.2, + weigh >=0.0.4 + + if flag(dev) + ghc-options: + -Wall -Werror -Wredundant-constraints -Wpartial-fields + -Wunused-packages + + else + ghc-options: -O2 -Wall