gigaparsec 0.2.4.0 → 0.2.4.1
raw patch · 8 files changed
+122/−46 lines, 8 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Text.Gigaparsec.Errors.ErrorBuilder: data Token
+ Text.Gigaparsec.Errors.ErrorBuilder: data () => Token
Files
- CHANGELOG.md +3/−0
- gigaparsec.cabal +4/−1
- src/Text/Gigaparsec/Errors/ErrorBuilder.hs +4/−32
- src/Text/Gigaparsec/Errors/TokenExtractors.hs +73/−0
- src/Text/Gigaparsec/Errors/TokenExtractors.hs-boot +22/−0
- src/Text/Gigaparsec/Internal/Token/Lexer.hs +11/−8
- src/Text/Gigaparsec/Internal/Token/Names.hs +1/−1
- src/Text/Gigaparsec/Internal/Token/Symbol.hs +4/−4
CHANGELOG.md view
@@ -1,5 +1,8 @@ # Revision history for gigaparsec +## 0.2.4.1 -- 2024-02-04+* Fixed infinite loop in lexer arising from forcing a knot-tie, the knot has been massaged out.+ ## 0.2.4.0 -- 2024-02-03 * Added `ErrorConfig` and related types, along with `mkLexerWithErrorConfig`, to now allow for custom lexing errors.
gigaparsec.cabal view
@@ -20,7 +20,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change-version: 0.2.4.0+version: 0.2.4.1 -- A short (one-line) description of the package. synopsis:@@ -78,6 +78,8 @@ library import: warnings, extensions, base + other-modules: Text.Gigaparsec.Errors.TokenExtractors+ -- Modules exported by the library. exposed-modules: Text.Gigaparsec, Text.Gigaparsec.Char,@@ -89,6 +91,7 @@ Text.Gigaparsec.Errors.ErrorBuilder, Text.Gigaparsec.Errors.ErrorGen, Text.Gigaparsec.Errors.Patterns,+ Text.Gigaparsec.Expr, Text.Gigaparsec.Expr.Chain, Text.Gigaparsec.Expr.Infix,
src/Text/Gigaparsec/Errors/ErrorBuilder.hs view
@@ -123,14 +123,14 @@ , disjunct, combineMessagesDefault , formatPosDefault, lineInfoDefault )+import {-# SOURCE #-} Text.Gigaparsec.Errors.TokenExtractors (Token(Named, Raw), tillNextWhitespace) -import Data.Char (isSpace, generalCategory, ord, GeneralCategory(Format, Surrogate, PrivateUse, NotAssigned, Control))+import Data.Char (isSpace) import Data.Kind (Constraint)-import Data.List.NonEmpty (NonEmpty((:|)))+import Data.List.NonEmpty (NonEmpty) import Data.Set (Set) import Data.Set qualified as Set (toList) import Data.String (IsString(fromString))-import Numeric (showHex) {-| This class describes how to format an error message generated by a parser into@@ -287,19 +287,6 @@ -> 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'.--There is deliberately no analogue for @EndOfInput@ because we guarantee that non-empty-residual input is provided to token extraction.--}-type Token :: *-data Token = Raw -- ^ This is a token that is directly extracted from the residual input itself.- !String -- ^ the input extracted.- | Named -- ^ This is a token that has been given a name, and is treated like a labelled item.- !String -- ^ the description of the token.- {-# UNPACK #-} !Word -- ^ the amount of residual input this token ate.--{-| Formats error messages as a string, using the functions found in "Text.Gigaparsec.Errors.DefaultErrorBuilder". -}@@ -361,19 +348,4 @@ endOfInput = endOfInputDefault {-# INLINABLE unexpectedToken #-}- -- TillNextWhitespace with matches parser demand- unexpectedToken ('\n' :| _) _ _ = Named "newline" 1- unexpectedToken ('\r' :| _) _ _ = Named "carriage return" 1- unexpectedToken ('\t' :| _) _ _ = Named "tab" 1- unexpectedToken (' ' :| _) _ _ = Named "space" 1- unexpectedToken (c :| cs) parserDemanded _- | isSpace c = Named "whitespace character" 1- | otherwise = case generalCategory c of- Format -> unprintable- Surrogate -> unprintable- PrivateUse -> unprintable- NotAssigned -> unprintable- Control -> unprintable- _ -> Raw (take (fromIntegral parserDemanded) (tillNextWhitespace (c:cs)))- where unprintable = Named ("non-printable character (\\x" ++ showHex (ord c) ")") 1- tillNextWhitespace = takeWhile (not . isSpace)+ unexpectedToken = tillNextWhitespace True isSpace
+ src/Text/Gigaparsec/Errors/TokenExtractors.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE Safe #-}+{-# LANGUAGE ViewPatterns #-}+module Text.Gigaparsec.Errors.TokenExtractors (+ Token(..), TokenExtractor,+ tillNextWhitespace,+ singleChar,+ matchParserDemand--,+ --lexToken+ ) where++import Text.Gigaparsec (Parsec)++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.Foldable (maximumBy)+import Numeric (showHex)+import Data.Function (on)++type TokenExtractor :: *+type TokenExtractor = NonEmpty Char -> Word -> Bool -> Token++{-|+This type represents an extracted token returned by 'unexpectedToken' in 'ErrorBuilder'.++There is deliberately no analogue for @EndOfInput@ because we guarantee that non-empty+residual input is provided to token extraction.+-}+type Token :: *+data Token = Raw -- ^ This is a token that is directly extracted from the residual input itself.+ !String -- ^ the input extracted.+ | Named -- ^ This is a token that has been given a name, and is treated like a labelled item.+ !String -- ^ the description of the token.+ {-# UNPACK #-} !Word -- ^ the amount of residual input this token ate.++{-# INLINABLE tillNextWhitespace #-}+-- TillNextWhitespace with matches parser demand+tillNextWhitespace :: Bool -> (Char -> Bool) -> 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)++singleChar :: TokenExtractor+singleChar (whitespaceOrUnprintable -> Just tok) _ _ = tok+singleChar (c :| _) _ _ = Raw [c]++matchParserDemand :: TokenExtractor+matchParserDemand (whitespaceOrUnprintable -> Just tok) _ _ = tok+matchParserDemand (c :| cs) parserDemanded _ = Raw (take (fromIntegral parserDemanded) (c:cs))++whitespaceOrUnprintable :: NonEmpty Char -> Maybe Token+whitespaceOrUnprintable ('\n' :| _) = Just $ Named "newline" 1+whitespaceOrUnprintable ('\r' :| _) = Just $ Named "carriage return" 1+whitespaceOrUnprintable ('\t' :| _) = Just $ Named "tab" 1+whitespaceOrUnprintable (' ' :| _) = Just $ Named "space" 1+whitespaceOrUnprintable (c :| _)+ | Char.isSpace c = Just $ Named "whitespace character" 1+ | otherwise = case generalCategory c of+ Format -> unprintable+ Surrogate -> unprintable+ PrivateUse -> unprintable+ NotAssigned -> unprintable+ Control -> unprintable+ _ -> Nothing+ where unprintable = Just $ Named ("non-printable character (\\x" ++ showHex (ord c) ")") 1++lexToken :: [Parsec String] -> TokenExtractor -> TokenExtractor+lexToken = lexTokenWithSelect (maximumBy (compare `on` snd))++lexTokenWithSelect :: (NonEmpty (String, Word) -> (String, Word)) -> [Parsec String] -> TokenExtractor -> TokenExtractor+lexTokenWithSelect = undefined
+ src/Text/Gigaparsec/Errors/TokenExtractors.hs-boot view
@@ -0,0 +1,22 @@+{-# LANGUAGE Safe #-}+module Text.Gigaparsec.Errors.TokenExtractors (module Text.Gigaparsec.Errors.TokenExtractors) where++import Data.List.NonEmpty (NonEmpty)++type TokenExtractor :: *+type TokenExtractor = NonEmpty Char -> Word -> Bool -> Token++{-|+This type represents an extracted token returned by 'unexpectedToken' in 'ErrorBuilder'.++There is deliberately no analogue for @EndOfInput@ because we guarantee that non-empty+residual input is provided to token extraction.+-}+type Token :: *+data Token = Raw -- ^ This is a token that is directly extracted from the residual input itself.+ !String -- ^ the input extracted.+ | Named -- ^ This is a token that has been given a name, and is treated like a labelled item.+ !String -- ^ the description of the token.+ {-# UNPACK #-} !Word -- ^ the amount of residual input this token ate.++tillNextWhitespace :: Bool -> (Char -> Bool) -> TokenExtractor
src/Text/Gigaparsec/Internal/Token/Lexer.hs view
@@ -67,11 +67,12 @@ mkLexerWithErrorConfig Desc.LexicalDesc{..} !errConfig = Lexer {..} where apply p = p <* whiteSpace space gen = mkGeneric errConfig+ -- DO NOT HAVE MUTUALLY RECURSIVE FIELDS lexeme = Lexeme { apply = apply , sym = apply . sym nonlexeme- , symbol = Symbol.lexeme apply (symbol nonlexeme)+ , symbol = Symbol.lexeme apply symbolNonLexeme , names = Names.lexeme apply (names nonlexeme)- , natural = Numeric.lexemeInteger apply (natural nonlexeme)+ , natural = Numeric.lexemeInteger apply naturalNonLexeme , integer = Numeric.lexemeInteger apply (integer nonlexeme) {-, floating = Numeric.lexemeFloating apply (floating nonlexeme) , unsignedCombined =@@ -84,13 +85,13 @@ , rawMultiStringLiteral = Text.lexeme apply (rawMultiStringLiteral nonlexeme) , charLiteral = Text.lexeme apply (charLiteral nonlexeme) }- nonlexeme = NonLexeme { sym = mkSym symbolDesc (symbol nonlexeme) errConfig- , symbol = mkSymbol symbolDesc nameDesc errConfig+ nonlexeme = NonLexeme { sym = mkSym symbolDesc symbolNonLexeme errConfig+ , symbol = symbolNonLexeme , names = mkNames nameDesc symbolDesc errConfig- , natural = mkUnsigned numericDesc gen errConfig- , integer = mkSigned numericDesc (natural nonlexeme) errConfig+ , natural = naturalNonLexeme+ , integer = mkSigned numericDesc naturalNonLexeme errConfig {-, floating = mkSignedFloating numericDesc positiveFloating- , unsignedCombined = mkUnsignedCombined numericDesc (natural nonlexeme) positiveFloating+ , unsignedCombined = mkUnsignedCombined numericDesc naturalNonLexeme positiveFloating , signedCombined = mkSignedCombined numericDesc (unsignedCombined nonlexeme)-} , stringLiteral = mkStringParsers stringEnds escapeChar graphicCharacter False errConfig , rawStringLiteral = mkStringParsers stringEnds rawChar graphicCharacter False errConfig@@ -98,7 +99,9 @@ , rawMultiStringLiteral = mkStringParsers multiStringEnds rawChar graphicCharacter True errConfig , charLiteral = mkCharacterParsers textDesc escape errConfig }- --positiveFloating = mkUnsignedFloating numericDesc (natural nonlexeme) gen+ !symbolNonLexeme = mkSymbol symbolDesc nameDesc errConfig+ !naturalNonLexeme = mkUnsigned numericDesc gen errConfig+ --positiveFloating = mkUnsignedFloating numericDesc naturalNonLexeme gen !escape = mkEscape (Desc.escapeSequences textDesc) gen errConfig graphicCharacter = Desc.graphicCharacter textDesc stringEnds = Desc.stringEnds textDesc
src/Text/Gigaparsec/Internal/Token/Names.hs view
@@ -35,7 +35,7 @@ } mkNames :: NameDesc -> SymbolDesc -> ErrorConfig -> Names-mkNames NameDesc{..} symbolDesc@SymbolDesc{..} err = Names {..}+mkNames NameDesc{..} symbolDesc@SymbolDesc{..} !err = Names {..} where !isReserved = isReservedName symbolDesc !identifier =
src/Text/Gigaparsec/Internal/Token/Symbol.hs view
@@ -28,14 +28,14 @@ } mkSymbol :: SymbolDesc -> NameDesc -> ErrorConfig -> Symbol-mkSymbol SymbolDesc{..} NameDesc{..} err = Symbol {..}+mkSymbol SymbolDesc{..} NameDesc{..} !err = Symbol {..} where softKeyword name = require (not (null name)) "softKeyword" "keywords may not be empty" (_softKeyword caseSensitive identifierLetter name err <?> [name]) softOperator name = require (not (null name)) "softOperator" "operators may not be empty" (_softOperator hardOperators operatorLetter name err <?> [name]) mkSym :: SymbolDesc -> Symbol -> ErrorConfig -> (String -> Parsec ())-mkSym SymbolDesc{..} Symbol{..} err str =+mkSym SymbolDesc{..} Symbol{..} !err str = annotate (Map.findWithDefault notConfigured str (labelSymbol err)) $ if | Set.member str hardKeywords -> softKeyword str | Set.member str hardOperators -> softOperator str@@ -47,7 +47,7 @@ } _softKeyword :: Bool -> CharPredicate -> String -> ErrorConfig -> Parsec ()-_softKeyword caseSensitive letter kw err+_softKeyword !caseSensitive !letter !kw !err | not caseSensitive = atomic (nfb letter caseString) <?> [kw] | otherwise = atomic (nfb letter (string kw)) <?> [kw] where nfb Nothing p = void p@@ -61,7 +61,7 @@ -- TODO: trie-based implementation _softOperator :: Set String -> CharPredicate -> String -> ErrorConfig -> Parsec ()-_softOperator hardOperators letter op err = label [op] $+_softOperator !hardOperators !letter !op !err = label [op] $ if Set.null ends then atomic (string op *> notFollowedBy letter') else atomic (string op *> (notFollowedBy (void letter' <|> void (strings ends)) <?> [labelSymbolEndOfOperator err op])) where ends = Set.fromList (mapMaybe (flip strip op) (Set.toList hardOperators))