diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for gigaparsec +## 0.2.5.0 -- 2024-02-04 +* Supported `Text.Gigaparsec.Errors.TokenExtractors`, which allows for recipes for token extraction + during error message creation. + ## 0.2.4.1 -- 2024-02-04 * Fixed infinite loop in lexer arising from forcing a knot-tie, the knot has been massaged out. diff --git a/gigaparsec.cabal b/gigaparsec.cabal --- a/gigaparsec.cabal +++ b/gigaparsec.cabal @@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.4.1 +version: 0.2.5.0 -- A short (one-line) description of the package. synopsis: @@ -78,8 +78,6 @@ library import: warnings, extensions, base - other-modules: Text.Gigaparsec.Errors.TokenExtractors - -- Modules exported by the library. exposed-modules: Text.Gigaparsec, Text.Gigaparsec.Char, @@ -91,7 +89,7 @@ Text.Gigaparsec.Errors.ErrorBuilder, Text.Gigaparsec.Errors.ErrorGen, Text.Gigaparsec.Errors.Patterns, - + Text.Gigaparsec.Errors.TokenExtractors, Text.Gigaparsec.Expr, Text.Gigaparsec.Expr.Chain, Text.Gigaparsec.Expr.Infix, diff --git a/src/Text/Gigaparsec/Errors/ErrorBuilder.hs b/src/Text/Gigaparsec/Errors/ErrorBuilder.hs --- a/src/Text/Gigaparsec/Errors/ErrorBuilder.hs +++ b/src/Text/Gigaparsec/Errors/ErrorBuilder.hs @@ -114,6 +114,7 @@ @since 0.2.0.0 -} +-- TODO: at 0.3.0.0, remove the Token re-export, because hs-boot doesn't carry docs module Text.Gigaparsec.Errors.ErrorBuilder (ErrorBuilder(..), Token(..)) where import Text.Gigaparsec.Errors.DefaultErrorBuilder ( StringBuilder, formatDefault @@ -131,6 +132,7 @@ import Data.Set (Set) import Data.Set qualified as Set (toList) import Data.String (IsString(fromString)) +import Data.Void (Void) {-| This class describes how to format an error message generated by a parser into @@ -277,7 +279,8 @@ can be reported instead. This can take many forms, for instance trimming the token to the next whitespace, only taking one character, or even trying to lex a token out of the stream. - TODO: talk about the token extractors when they are added. + This method can be easily implemented by using an appropriate /token extractor/ from + "Text.Gigaparsec.Errors.TokenExtractors". -} unexpectedToken :: NonEmpty Char -- ^ the remaining input, @cs@, at point of failure. -> Word -- ^ the input the parser tried to read when it failed @@ -349,3 +352,72 @@ {-# INLINABLE unexpectedToken #-} unexpectedToken = tillNextWhitespace True isSpace + +{-| +Can be used to ignore error messages, by just returning a @()@. +-} +instance ErrorBuilder () where + format _ _ _ = () + type Position () = () + type Source () = () + type ErrorInfoLines () = () + type ExpectedItems () = () + type Messages () = () + type UnexpectedLine () = () + type ExpectedLine () = () + type Message () = () + type LineInfo () = () + type Item () = () + + pos = undefined + source = undefined + vanillaError = undefined + specialisedError = undefined + combineExpectedItems = undefined + combineMessages = undefined + unexpected = undefined + expected = undefined + reason = undefined + message = undefined + lineInfo = undefined + numLinesBefore = undefined + numLinesAfter = undefined + raw = undefined + named = undefined + endOfInput = undefined + unexpectedToken = undefined + +{-| +This builder denotes that failure of a parser is impossible, as its errors are +uninhabited. +-} +instance ErrorBuilder Void where + format = undefined + type Position Void = Void + type Source Void = Void + type ErrorInfoLines Void = Void + type ExpectedItems Void = Void + type Messages Void = Void + type UnexpectedLine Void = Void + type ExpectedLine Void = Void + type Message Void = Void + type LineInfo Void = Void + type Item Void = Void + + pos = undefined + source = undefined + vanillaError = undefined + specialisedError = undefined + combineExpectedItems = undefined + combineMessages = undefined + unexpected = undefined + expected = undefined + reason = undefined + message = undefined + lineInfo = undefined + numLinesBefore = undefined + numLinesAfter = undefined + raw = undefined + named = undefined + endOfInput = undefined + unexpectedToken = undefined diff --git a/src/Text/Gigaparsec/Errors/TokenExtractors.hs b/src/Text/Gigaparsec/Errors/TokenExtractors.hs --- a/src/Text/Gigaparsec/Errors/TokenExtractors.hs +++ b/src/Text/Gigaparsec/Errors/TokenExtractors.hs @@ -1,30 +1,73 @@ {-# LANGUAGE Safe #-} {-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-| +Module : Text.Gigaparsec.Errors.TokenExtractors +Description : This module contains implementations of token extractors that can be used in the + @ErrorBuilder@ to decide how to extract unexpected tokens from the residual input left + over from a parse error. +License : BSD-3-Clause +Maintainer : Jamie Willis, Gigaparsec Maintainers +Stability : stable + +This module contains implementations of token extractors that can be used in the +"Text.Gigaparsec.Errors.ErrorBuilder" to decide how to extract unexpected tokens from the residual +input left over from a parse error. + +These are common strategies, and something here is likely to be what is needed. They are all careful +to handle unprintable characters and whitespace in a sensible way, and account for unicode codepoints +that are wider than a single 16-bit character. + +@since 0.2.5.0 +-} module Text.Gigaparsec.Errors.TokenExtractors ( Token(..), TokenExtractor, tillNextWhitespace, singleChar, - matchParserDemand--, - --lexToken + matchParserDemand, + lexToken, lexTokenWithSelect ) where -import Text.Gigaparsec (Parsec) +import Text.Gigaparsec ( + Parsec, Result(Success), parse, + atomic, lookAhead, notFollowedBy, some, (<+>), (<~>), mapMaybeS + ) +import Text.Gigaparsec.Char (item) +import Text.Gigaparsec.Combinator (option) +import Text.Gigaparsec.Position (offset) import Data.Char (generalCategory, ord, GeneralCategory(Format, Surrogate, PrivateUse, NotAssigned, Control)) import Data.Char qualified as Char (isSpace) -import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List.NonEmpty (NonEmpty((:|)), nonEmpty) +import Data.List.NonEmpty qualified as NonEmpty (toList) +import Data.Void (Void) import Data.Foldable (maximumBy) import Numeric (showHex) import Data.Function (on) +import Data.Maybe (catMaybes) +{-| +Type alias for token extractors, matches the shape of +'Text.Gigaparsec.Errors.ErrorBuilder.unexpectedToken'. + +@since 0.2.5.0 +-} type TokenExtractor :: * -type TokenExtractor = NonEmpty Char -> Word -> Bool -> Token +type TokenExtractor = NonEmpty Char -- ^ the remaining input, @cs@, at point of failure. + -> Word -- ^ the input the parser tried to read when it failed + -- (this is __not__ guaranteed to be smaller than the length of + -- @cs@, but is __guaranteed to be greater than 0__). + -> Bool -- ^ was this error generated as part of \"lexing\", or in a wider parser (see 'Text.Gigaparsec.Errors.Combinator.markAsToken'). + -> Token -- ^ a token extracted from @cs@ that will be used as part of the unexpected message. {-| -This type represents an extracted token returned by 'unexpectedToken' in 'ErrorBuilder'. +This type represents an extracted token returned by 'Text.Gigaparsec.Errors.ErrorBuilder.unexpectedToken' +in 'Text.Gigaparsec.Errors.ErrorBuilder.ErrorBuilder'. There is deliberately no analogue for @EndOfInput@ because we guarantee that non-empty residual input is provided to token extraction. + +@since 0.2.5.0 -} type Token :: * data Token = Raw -- ^ This is a token that is directly extracted from the residual input itself. @@ -34,22 +77,55 @@ {-# UNPACK #-} !Word -- ^ the amount of residual input this token ate. {-# INLINABLE tillNextWhitespace #-} --- TillNextWhitespace with matches parser demand -tillNextWhitespace :: Bool -> (Char -> Bool) -> TokenExtractor +{-| +This extractor provides an implementation for 'Text.Gigaparsec.ErrorBuilder.unexpectedToken': +it will construct a token that extends to the next available whitespace in the remaining input. +It can be configured to constrict this token to the minimum of the next whitespace or whatever the +parser demanded. + +In the case of unprintable characters or whitespace, this extractor will favour reporting a more +meaningful name. + +@since 0.2.5.0 +-} +tillNextWhitespace :: Bool -- ^ should the extractor cap the token to the amount of input the parser demanded? + -> (Char -> Bool) -- ^ what counts as a space character + -> TokenExtractor tillNextWhitespace _ _ (whitespaceOrUnprintable -> Just tok) _ _ = tok tillNextWhitespace trimToDemand isSpace (c :| cs) parserDemanded _ | trimToDemand = Raw (take (fromIntegral parserDemanded) (tillSpace (c:cs))) | otherwise = Raw (tillSpace (c:cs)) where tillSpace = takeWhile (not . isSpace) +{-| +This extractor provides an implementation for 'Text.Gigaparsec.ErrorBuilder.unexpectedToken': +it will unconditionally report the first character in the remaining input as the problematic token. + +In the case of unprintable characters or whitespace, this extractor will favour reporting +a more meaningful name. + +@since 0.2.5.0 +-} +{-# INLINABLE singleChar #-} singleChar :: TokenExtractor singleChar (whitespaceOrUnprintable -> Just tok) _ _ = tok singleChar (c :| _) _ _ = Raw [c] +{-| +This extractor provides an implementation for 'Text.Gigaparsec.ErrorBuilder.unexpectedToken': +it will make a token as wide as the amount of input the parser tried to consume when it failed. + +In the case of unprintable characters or whitespace, this extractor will favour reporting a more +meaningful name. + +@since 0.2.5.0 +-} +{-# INLINABLE matchParserDemand #-} matchParserDemand :: TokenExtractor matchParserDemand (whitespaceOrUnprintable -> Just tok) _ _ = tok matchParserDemand (c :| cs) parserDemanded _ = Raw (take (fromIntegral parserDemanded) (c:cs)) +{-# INLINABLE whitespaceOrUnprintable #-} whitespaceOrUnprintable :: NonEmpty Char -> Maybe Token whitespaceOrUnprintable ('\n' :| _) = Just $ Named "newline" 1 whitespaceOrUnprintable ('\r' :| _) = Just $ Named "carriage return" 1 @@ -66,8 +142,97 @@ _ -> Nothing where unprintable = Just $ Named ("non-printable character (\\x" ++ showHex (ord c) ")") 1 -lexToken :: [Parsec String] -> TokenExtractor -> TokenExtractor +{-| +This extractor provides an implementation for 'Text.Gigaparsec.ErrorBuilder.unexpectedToken': +it will try and parse the residual input to identify a valid lexical token to report. + +When parsing a grammar that as a dedicated lexical distinction, it is nice to be able to report +problematic tokens relevant to that grammar as opposed to generic input lifted straight from the +input stream. The easiest way of doing this would be having a pre-lexing pass and parsing based +on tokens, but this is deliberately not how Parsley is designed. Instead, this extractor can +try and parse the remaining input to try and identify a token on demand. + +If the @lexicalError@ flag of the @unexpectedToken@ function is not set, which would indicate a +problem within a token reported by a classical lexer and not the parser, the extractor will +try to parse each of the provided @tokens@ in turn: whichever is the longest matched of these +tokens will be reported as the problematic one, where an earlier token arbitrates ties +('lexTokenWithSelect' can alter which is chosen). For best effect, these tokens should not consume +whitespace (which would otherwise be included at the end of the token!): this means that, if +using the @Lexer@, the functionality in __@nonlexeme@__ should be used. If one of the +givens tokens cannot be parsed, the input until the /next/ valid parsable token (or end of input) +is returned as a @Raw@. + +If @lexicalError@ is true, then the given token extractor will be used instead to extract a +default token. + +@since 0.2.5.0 +-} +{-# INLINABLE lexToken #-} +lexToken :: [Parsec String] -- ^ The tokens that should be recognised by this extractor: each parser should return the + -- intended name of the token exactly as it should appear in the "Named" token. + -- + -- This /should/ include a whitespace parser for "unexpected whitespace". However, with the + -- exception of the whitespace parser, these tokens should not consume trailing (and + -- certainly not leading) whitespace: if using definitions from "Text.Gigaparsec.Token.Lexer" + -- functionality, the @nonlexeme@ versions of the tokens should be used. + -> TokenExtractor -- ^ If the parser failed during the parsing of a token, this + -- function extracts the problematic item from the remaining input. + -> TokenExtractor lexToken = lexTokenWithSelect (maximumBy (compare `on` snd)) -lexTokenWithSelect :: (NonEmpty (String, Word) -> (String, Word)) -> [Parsec String] -> TokenExtractor -> TokenExtractor -lexTokenWithSelect = undefined +{-| +This extractor provides an implementation for 'Text.Gigaparsec.ErrorBuilder.unexpectedToken': +it will try and parse the residual input to identify a valid lexical token to report. + +When parsing a grammar that as a dedicated lexical distinction, it is nice to be able to report +problematic tokens relevant to that grammar as opposed to generic input lifted straight from the +input stream. The easiest way of doing this would be having a pre-lexing pass and parsing based +on tokens, but this is deliberately not how Parsley is designed. Instead, this extractor can +try and parse the remaining input to try and identify a token on demand. + +If the @lexicalError@ flag of the @unexpectedToken@ function is not set, which would indicate a +problem within a token reported by a classical lexer and not the parser, the extractor will +try to parse each of the provided @tokens@ in turn: the given function is used to select which +is returned. +For best effect, these tokens should not consume +whitespace (which would otherwise be included at the end of the token!): this means that, if +using the @Lexer@, the functionality in __@nonlexeme@__ should be used. If one of the +givens tokens cannot be parsed, the input until the /next/ valid parsable token (or end of input) +is returned as a @Raw@. + +If @lexicalError@ is true, then the given token extractor will be used instead to extract a +default token. + +@since 0.2.5.0 +-} +{-# INLINABLE lexTokenWithSelect #-} +lexTokenWithSelect :: (NonEmpty (String, Word) -> (String, Word)) + -- ^ If the extractor is successful in identifying tokens that can be parsed from + -- the residual input, this function will select /one/ of them to report back. + -> [Parsec String] + -- ^ The tokens that should be recognised by this extractor: each parser should return the + -- intended name of the token exactly as it should appear in the "Named" token. + -- + -- This /should/ include a whitespace parser for "unexpected whitespace". However, with the + -- exception of the whitespace parser, these tokens should not consume trailing (and + -- certainly not leading) whitespace: if using definitions from "Text.Gigaparsec.Token.Lexer" + -- functionality, the @nonlexeme@ versions of the tokens should be used. + -> TokenExtractor + -- ^ If the parser failed during the parsing of a token, this + -- function extracts the problematic item from the remaining input. + -> TokenExtractor +lexTokenWithSelect selectToken tokens extractItem cs parserDemanded lexical + | lexical = extractItem cs parserDemanded True + | otherwise = extractToken cs + where + extractToken :: NonEmpty Char -> Token + extractToken inp = + let Success rawOrToks = parse @Void parser (NonEmpty.toList inp) + in either (uncurry Named . selectToken) Raw rawOrToks + + parser :: Parsec (Either (NonEmpty (String, Word)) String) + parser = + let toks = mapMaybeS (nonEmpty . catMaybes) + (traverse (\t -> option (lookAhead (atomic t <~> offset))) tokens) + rawTok = some (traverse notFollowedBy tokens *> item) + in toks <+> rawTok