megaparsec 9.3.1 → 9.8.1
raw patch · 17 files changed
Files
- CHANGELOG.md +76/−0
- README.md +3/−1
- Setup.hs +0/−6
- Text/Megaparsec.hs +12/−26
- Text/Megaparsec/Byte/Lexer.hs +7/−7
- Text/Megaparsec/Char/Lexer.hs +13/−13
- Text/Megaparsec/Class.hs +18/−2
- Text/Megaparsec/Debug.hs +21/−8
- Text/Megaparsec/Error.hs +84/−23
- Text/Megaparsec/Error/Builder.hs +10/−11
- Text/Megaparsec/Internal.hs +101/−28
- Text/Megaparsec/Internal.hs-boot +10/−0
- Text/Megaparsec/Pos.hs +3/−4
- Text/Megaparsec/State.hs +41/−3
- Text/Megaparsec/Stream.hs +53/−29
- Text/Megaparsec/Unicode.hs +223/−0
- megaparsec.cabal +35/−27
CHANGELOG.md view
@@ -1,5 +1,81 @@ *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
README.md view
@@ -4,7 +4,7 @@ [](https://hackage.haskell.org/package/megaparsec) [](http://stackage.org/nightly/package/megaparsec) [](http://stackage.org/lts/package/megaparsec)-+[](https://github.com/mrkkrp/megaparsec/actions/workflows/ci.yaml) * [Features](#features) * [Core features](#core-features)@@ -282,6 +282,8 @@ [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
− Setup.hs
@@ -1,6 +0,0 @@-module Main (main) where--import Distribution.Simple--main :: IO ()-main = defaultMain
Text/Megaparsec.hs view
@@ -130,12 +130,16 @@ -- -- 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@@ -288,31 +292,13 @@ 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 the name of source file and the input construct the initial state--- for a 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 @@ -400,8 +386,8 @@ -- | 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 the--- 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@@ -534,10 +520,10 @@ -- | Collection of matching tokens f (Token s) -> m (Token s)-oneOf cs = satisfy (`elem` cs)+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@@ -553,10 +539,10 @@ -- @since 7.0.0 noneOf :: (Foldable f, MonadParsec e s m) =>- -- | Collection of taken we should not match+ -- | Collection of tokens we should not match f (Token s) -> m (Token s)-noneOf cs = satisfy (`notElem` cs)+noneOf cs = satisfy (\x -> notElem x cs) {-# INLINE noneOf #-} -- | @'chunk' chk@ only matches the chunk @chk@.
Text/Megaparsec/Byte/Lexer.hs view
@@ -41,7 +41,7 @@ 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@@ -69,7 +69,7 @@ -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. skipBlockComment ::- (MonadParsec e s m, Token s ~ Word8) =>+ (MonadParsec e s m) => -- | Start of block comment Tokens s -> -- | End of block comment@@ -122,7 +122,7 @@ 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_ #-} @@ -145,7 +145,7 @@ <$> takeWhile1P Nothing isBinDigit <?> "binary integer" where- mkNum = foldl' step 0 . chunkToTokens (Proxy :: Proxy s)+ 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 #-}@@ -170,7 +170,7 @@ <$> takeWhile1P Nothing 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 w = a * 8 + fromIntegral (w - 48) isOctDigit w = w - 48 < 8 {-# INLINEABLE octal #-}@@ -195,7 +195,7 @@ <$> 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)@@ -256,7 +256,7 @@ m SP dotDecimal_ pxy c' = do void (B.char 46)- let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy+ let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy step (SP a e') w = SP (a * 10 + fromIntegral (w - 48))
Text/Megaparsec/Char/Lexer.hs view
@@ -69,7 +69,7 @@ import Control.Applicative import Control.Monad (void) import qualified Data.Char as Char-import Data.List (foldl')+import qualified Data.List import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Proxy@@ -99,7 +99,7 @@ -- | @'skipBlockComment' start end@ skips non-nested block comment starting -- with @start@ and ending with @end@. skipBlockComment ::- (MonadParsec e s m, Token s ~ Char) =>+ (MonadParsec e s m) => -- | Start of block comment Tokens s -> -- | End of block comment@@ -258,9 +258,9 @@ let lvl = fromMaybe pos indent x <- if- | pos <= ref -> incorrectIndent GT ref pos- | pos == lvl -> p- | otherwise -> incorrectIndent EQ lvl pos+ | 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 #-}@@ -288,9 +288,9 @@ then return [] else if- | pos <= ref -> return []- | pos == lvl -> (:) <$> p <*> go- | otherwise -> incorrectIndent EQ lvl pos+ | 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/@@ -372,7 +372,7 @@ 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_ #-} @@ -395,7 +395,7 @@ <$> takeWhile1P Nothing isBinDigit <?> "binary 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 * 2 + fromIntegral (Char.digitToInt c) isBinDigit x = x == '0' || x == '1' {-# INLINEABLE binary #-}@@ -423,7 +423,7 @@ <$> 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 #-} @@ -450,7 +450,7 @@ <$> 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 #-} @@ -510,7 +510,7 @@ m SP dotDecimal_ pxy c' = do void (C.char '.')- let mkNum = foldl' step (SP c' 0) . chunkToTokens pxy+ let mkNum = Data.List.foldl' step (SP c' 0) . chunkToTokens pxy step (SP a e') c = SP (a * 10 + fromIntegral (Char.digitToInt c))
Text/Megaparsec/Class.hs view
@@ -37,6 +37,7 @@ 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 @@ -125,7 +126,7 @@ -- to the point where the next object starts. -- -- Note that if @r@ fails, the original error message is reported as if- -- without 'withRecovery'. In no way recovering parser @r@ can influence+ -- without 'withRecovery'. In no way can the recovering parser @r@ influence -- error messages. -- -- @since 4.4.0@@ -244,7 +245,7 @@ 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. --@@ -272,6 +273,13 @@ -- | @'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 @@ -295,6 +303,7 @@ 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)@@ -316,6 +325,7 @@ 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)@@ -334,6 +344,7 @@ 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)@@ -359,6 +370,7 @@ 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)@@ -384,6 +396,7 @@ 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@@ -408,6 +421,7 @@ 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@@ -432,6 +446,7 @@ 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)@@ -451,6 +466,7 @@ 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)
Text/Megaparsec/Debug.hs view
@@ -31,8 +31,10 @@ 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@@ -223,7 +225,7 @@ cok' x s' hs = flip trace (cok x s' hs) $ l (DbgIn (unfold (stateInput s)))- ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x)+ ++ l (DbgCOK (streamTake (streamDelta s s') (stateInput s)) x hs) cerr' err s' = flip trace (cerr err s') $ l (DbgIn (unfold (stateInput s)))@@ -231,7 +233,7 @@ eok' x s' hs = flip trace (eok x s' hs) $ l (DbgIn (unfold (stateInput s)))- ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x)+ ++ l (DbgEOK (streamTake (streamDelta s s') (stateInput s)) x hs) eerr' err s' = flip trace (eerr err s') $ l (DbgIn (unfold (stateInput s)))@@ -241,9 +243,9 @@ -- | A single piece of info to be rendered with 'dbgLog'. data DbgItem s e a = DbgIn [Token s]- | DbgCOK [Token s] a+ | 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.@@ -260,15 +262,26 @@ 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 -> "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
Text/Megaparsec/Error.hs view
@@ -41,11 +41,15 @@ -- * Pretty-printing ShowErrorComponent (..), errorBundlePretty,+ errorBundlePrettyForGhcPreProcessors,+ errorBundlePrettyWith, parseErrorPretty, parseErrorTextPretty,+ showErrorItem, ) where +import Control.Arrow ((>>>)) import Control.DeepSeq import Control.Exception import Control.Monad.State.Strict@@ -63,6 +67,7 @@ import Text.Megaparsec.Pos import Text.Megaparsec.State import Text.Megaparsec.Stream+import qualified Text.Megaparsec.Unicode as Unicode ---------------------------------------------------------------------------- -- Parse error type@@ -78,7 +83,7 @@ Label (NonEmpty Char) | -- | End of input EndOfInput- deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)+ deriving (Show, Read, Eq, Ord, Data, Generic, Functor) instance (NFData t) => NFData (ErrorItem t) @@ -96,7 +101,7 @@ ErrorIndentation Ordering Pos Pos | -- | Custom error data ErrorCustom e- deriving (Show, Read, Eq, Ord, Data, Typeable, Generic, Functor)+ deriving (Show, Read, Eq, Ord, Data, Generic, Functor) instance (NFData a) => NFData (ErrorFancy a) where rnf (ErrorFail str) = rnf str@@ -124,7 +129,7 @@ -- -- Type of the first argument was changed in the version /7.0.0/. FancyError Int (Set (ErrorFancy e))- deriving (Typeable, Generic)+ deriving (Generic) deriving instance ( Show (Token s),@@ -163,8 +168,7 @@ {-# INLINE mappend #-} instance- ( Show s,- Show (Token s),+ ( Show (Token s), Show e, ShowErrorComponent e, VisualStream s,@@ -265,13 +269,6 @@ Eq (ParseErrorBundle s e) deriving instance- ( Typeable s,- Typeable (Token s),- Typeable e- ) =>- Typeable (ParseErrorBundle s e)--deriving instance ( Data s, Data (Token s), Ord (Token s),@@ -347,24 +344,24 @@ 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 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 ::+-- @since 9.7.0+errorBundlePrettyWith :: forall s e. ( VisualStream s,- TraversableStream s,- ShowErrorComponent e+ 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-errorBundlePretty ParseErrorBundle {..} =+errorBundlePrettyWith format ParseErrorBundle {..} = let (r, _) = foldl f (id, bundlePosState) bundleErrors- in drop 1 (r "")+ in r "" where f :: (ShowS, PosState s) ->@@ -374,6 +371,33 @@ where (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@@ -391,12 +415,12 @@ pointerLen = if rpshift + elen > slineLen then slineLen - rpshift + 1- else elen+ else max 1 elen pointer = replicate pointerLen '^' lineNumber = (show . unPos . sourceLine) epos padding = replicate (length lineNumber + 1) ' ' rpshift = unPos (sourceColumn epos) - 1- slineLen = length sline+ slineLen = Unicode.stringLength sline in padding <> "|\n" <> lineNumber@@ -416,6 +440,41 @@ 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. --@@ -458,6 +517,8 @@ -- Helpers -- | Pretty-print an 'ErrorItem'.+--+-- @since 9.4.0 showErrorItem :: (VisualStream s) => Proxy s -> ErrorItem (Token s) -> String showErrorItem pxy = \case Tokens ts -> showTokens pxy ts
Text/Megaparsec/Error/Builder.hs view
@@ -47,7 +47,6 @@ import Data.Proxy import Data.Set (Set) import qualified Data.Set as E-import Data.Typeable (Typeable) import GHC.Generics import Text.Megaparsec.Error import Text.Megaparsec.Stream@@ -57,7 +56,7 @@ -- | 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) @@ -84,7 +83,7 @@ -- | 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 EF xs0 <> EF xs1 = EF (E.union xs0 xs1)@@ -122,7 +121,7 @@ -- 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@@ -132,17 +131,17 @@ -- | 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@@ -152,13 +151,13 @@ -- | 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.@@ -181,11 +180,11 @@ 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.
Text/Megaparsec/Internal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-}@@ -5,6 +6,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -44,6 +46,7 @@ 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@@ -52,6 +55,7 @@ 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@@ -95,10 +99,12 @@ -- | All information available after parsing. This includes consumption of -- input, success (with the returned value) or failure (with the parse--- error), and parser state at the end of parsing.+-- 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. --@@ -107,17 +113,18 @@ = -- | Some part of input stream was consumed Consumed | -- | No input was consumed- Virgin+ 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- = -- | Parser succeeded- OK a+ = -- | 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@.@@ -168,7 +175,9 @@ pure = pPure (<*>) = pAp p1 *> p2 = p1 `pBind` const p2+ {-# INLINE (*>) #-} p1 <* p2 = do x1 <- p1; void p2; return x1+ {-# INLINE (<*) #-} pPure :: (Stream s) => a -> ParsecT e s m a pPure x = ParsecT $ \s _ _ eok _ -> eok x s mempty@@ -203,6 +212,8 @@ instance (Ord e, Stream s) => Alternative (ParsecT e s m) where 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@@ -248,44 +259,82 @@ 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)+ 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+ runParsecT (f (\a -> mkParsecT $ \s' -> c (pack s' a))) s where- pack s a = Reply s Virgin (OK a)+ 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 :: (Stream s, 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 #-} +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 = mero+-- > v >> mzero = mzero -- -- However the following holds: --@@ -308,9 +357,32 @@ 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')+ 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@@ -326,9 +398,9 @@ -- | @since 6.0.0 instance (Stream s, MonadFix m) => MonadFix (ParsecT e s m) where- mfix f = mkPT $ \s -> mfix $ \(~(Reply _ _ result)) -> do+ mfix f = mkParsecT $ \s -> mfix $ \(~(Reply _ _ result)) -> do let a = case result of- OK a' -> a'+ OK _ a' -> a' Error _ -> error "mfix ParsecT" runParsecT (f a) s @@ -352,6 +424,7 @@ takeP = pTakeP getParserState = pGetParserState updateParserState = pUpdateParserState+ mkParsec = pmkParsec pParseError :: ParseError s e ->@@ -390,10 +463,10 @@ 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+ unexpected u = TrivialError o (pure u) E.empty+ cok' _ _ _ = eerr (unexpected what) s cerr' _ _ = eok () s mempty- eok' _ _ _ = eerr (unexpect what) s+ eok' _ _ _ = eerr (unexpected what) s eerr' _ _ = eok () s mempty in unParser p s cok' cerr' eok' eerr' {-# INLINE pNotFollowedBy #-}@@ -471,14 +544,14 @@ 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 len = chunkLength pxy tts in case takeN_ len input of Nothing ->- eerr (unexpect o EndOfInput) s+ eerr (unexpected o EndOfInput) s Just (tts', input') -> if f tts tts' then@@ -488,7 +561,7 @@ 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 eerr (unexpected o ps) (State input o pst de) {-# INLINE pTokens #-} pTakeWhileP ::@@ -651,10 +724,10 @@ 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@.@@ -667,7 +740,7 @@ -- @since 7.0.0 withParsecT :: forall e e' s m a.- (Monad m, Ord e') =>+ (Ord e') => (e -> e') -> -- | Inner parser ParsecT e s m a ->
+ Text/Megaparsec/Internal.hs-boot view
@@ -0,0 +1,10 @@+{-# LANGUAGE RoleAnnotations #-}++module Text.Megaparsec.Internal+ ( Reply,+ )+where++type role Reply nominal nominal representational++data Reply e s a
Text/Megaparsec/Pos.hs view
@@ -36,7 +36,6 @@ import Control.DeepSeq import Control.Exception import Data.Data (Data)-import Data.Typeable (Typeable) import GHC.Generics ----------------------------------------------------------------------------@@ -49,7 +48,7 @@ -- -- @since 5.0.0 newtype Pos = Pos Int- deriving (Show, Eq, Ord, Data, Generic, Typeable, NFData)+ deriving (Show, Eq, Ord, Data, Generic, NFData) -- | Construction of 'Pos' from 'Int'. The function throws -- 'InvalidPosException' when given a non-positive argument.@@ -105,7 +104,7 @@ newtype InvalidPosException = -- | Contains the actual value that was passed to 'mkPos' InvalidPosException Int- deriving (Eq, Show, Data, Typeable, Generic)+ deriving (Eq, Show, Data, Generic) instance Exception InvalidPosException @@ -126,7 +125,7 @@ -- | Column number sourceColumn :: !Pos }- deriving (Show, Read, Eq, Ord, Data, Typeable, Generic)+ deriving (Show, Read, Eq, Ord, Data, Generic) instance NFData SourcePos
Text/Megaparsec/State.hs view
@@ -21,13 +21,14 @@ -- @since 6.5.0 module Text.Megaparsec.State ( State (..),+ initialState, PosState (..),+ initialPosState, ) where import Control.DeepSeq (NFData) import Data.Data (Data)-import Data.Typeable (Typeable) import GHC.Generics import {-# SOURCE #-} Text.Megaparsec.Error (ParseError) import Text.Megaparsec.Pos@@ -51,7 +52,7 @@ -- @since 8.0.0 stateParseErrors :: [ParseError s e] }- deriving (Typeable, Generic)+ deriving (Generic) deriving instance ( Show (ParseError s e),@@ -74,6 +75,24 @@ instance (NFData s, NFData (ParseError s e)) => NFData (State s e) +-- | Given the name of the source file and the input construct the initial+-- state for a parser.+--+-- @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. --@@ -90,6 +109,25 @@ -- | Prefix to prepend to offending line pstateLinePrefix :: String }- deriving (Show, Eq, Data, Typeable, Generic)+ deriving (Show, Eq, Data, Generic) 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 = ""+ }
Text/Megaparsec/Stream.hs view
@@ -40,8 +40,9 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy.Char8 as BL8 import Data.Char (chr)-import Data.Foldable (foldl', toList)+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)@@ -52,6 +53,7 @@ import Data.Word (Word8) import Text.Megaparsec.Pos import Text.Megaparsec.State+import qualified Text.Megaparsec.Unicode as Unicode -- | Type class for inputs that can be consumed by the library. --@@ -426,6 +428,7 @@ instance VisualStream String where showTokens Proxy = stringPretty+ tokensLength Proxy = Unicode.stringLength instance VisualStream B.ByteString where showTokens Proxy = stringPretty . fmap (chr . fromIntegral)@@ -435,9 +438,11 @@ 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. --@@ -510,37 +515,37 @@ 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 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 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 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 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@@ -564,6 +569,8 @@ (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@@ -576,6 +583,7 @@ fromToks fromTok (newlineTok, tabTok)+ columnIncrement o PosState {..} = ( Just $ case expandTab pstateTabWidth@@ -614,18 +622,18 @@ 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 :))+ | 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'.@@ -638,6 +646,8 @@ (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@@ -648,6 +658,7 @@ splitAt' foldl'' (newlineTok, tabTok)+ columnIncrement o PosState {..} = ( PosState@@ -665,12 +676,12 @@ 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)+ | 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'.@@ -753,3 +764,16 @@ 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
+ Text/Megaparsec/Unicode.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE Safe #-}++-- |+-- Module : Text.Megaparsec.Unicode+-- Copyright : © 2024–present Megaparsec contributors+-- License : FreeBSD+--+-- Maintainer : Mark Karpov <markkarpov92@gmail.com>+-- 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 #-}
megaparsec.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: megaparsec-version: 9.3.1+version: 9.8.1 license: BSD-2-Clause license-file: LICENSE.md maintainer: Mark Karpov <markkarpov92@gmail.com>@@ -9,7 +9,9 @@ Paolo Martini <paolo@nemail.it>, Daan Leijen <daan@microsoft.com> -tested-with: ghc ==9.0.2 ghc ==9.2.5 ghc ==9.4.4+tested-with:+ ghc ==9.6.7 ghc ==9.8.4 ghc ==9.10.3 ghc ==9.12.4 ghc ==9.14.1+ homepage: https://github.com/mrkkrp/megaparsec bug-reports: https://github.com/mrkkrp/megaparsec/issues synopsis: Monadic parser combinators@@ -46,37 +48,39 @@ 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- Text.Megaparsec.State default-language: Haskell2010 build-depends:- base >=4.15 && <5.0,- bytestring >=0.2 && <0.12,+ 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.7,- deepseq >=1.3 && <1.5,- mtl >=2.2.2 && <3.0,- parser-combinators >=1.0 && <2.0,+ 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.1,+ text >=0.2 && <2.2, transformers >=0.4 && <0.7 if flag(dev)- ghc-options: -O0 -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall - if flag(dev)- ghc-options:- -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns- -Wnoncanonical-monad-instances -Wno-missing-home-modules+ if impl(ghc >=9.8)+ ghc-options: -Wno-x-partial benchmark bench-speed type: exitcode-stdio-1.0@@ -84,16 +88,18 @@ hs-source-dirs: bench/speed default-language: Haskell2010 build-depends:- base >=4.15 && <5.0,- bytestring >=0.2 && <0.12,- containers >=0.5 && <0.7,+ 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.5,+ deepseq >=1.3 && <1.6, megaparsec,- text >=0.2 && <2.1+ text >=0.2 && <2.2 if flag(dev)- ghc-options: -O2 -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall@@ -104,16 +110,18 @@ hs-source-dirs: bench/memory default-language: Haskell2010 build-depends:- base >=4.15 && <5.0,- bytestring >=0.2 && <0.12,- containers >=0.5 && <0.7,- deepseq >=1.3 && <1.5,+ base >=4.18 && <5,+ bytestring >=0.2 && <0.13,+ containers >=0.5 && <0.9,+ deepseq >=1.3 && <1.6, megaparsec,- text >=0.2 && <2.1,+ text >=0.2 && <2.2, weigh >=0.0.4 if flag(dev)- ghc-options: -O2 -Wall -Werror+ ghc-options:+ -Wall -Werror -Wredundant-constraints -Wpartial-fields+ -Wunused-packages else ghc-options: -O2 -Wall