diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. 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.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, 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 @@ -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 diff --git a/src/Text/Gigaparsec/Errors/TokenExtractors.hs b/src/Text/Gigaparsec/Errors/TokenExtractors.hs new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Errors/TokenExtractors.hs @@ -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 diff --git a/src/Text/Gigaparsec/Errors/TokenExtractors.hs-boot b/src/Text/Gigaparsec/Errors/TokenExtractors.hs-boot new file mode 100644 --- /dev/null +++ b/src/Text/Gigaparsec/Errors/TokenExtractors.hs-boot @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Lexer.hs b/src/Text/Gigaparsec/Internal/Token/Lexer.hs --- a/src/Text/Gigaparsec/Internal/Token/Lexer.hs +++ b/src/Text/Gigaparsec/Internal/Token/Lexer.hs @@ -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 diff --git a/src/Text/Gigaparsec/Internal/Token/Names.hs b/src/Text/Gigaparsec/Internal/Token/Names.hs --- a/src/Text/Gigaparsec/Internal/Token/Names.hs +++ b/src/Text/Gigaparsec/Internal/Token/Names.hs @@ -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 = diff --git a/src/Text/Gigaparsec/Internal/Token/Symbol.hs b/src/Text/Gigaparsec/Internal/Token/Symbol.hs --- a/src/Text/Gigaparsec/Internal/Token/Symbol.hs +++ b/src/Text/Gigaparsec/Internal/Token/Symbol.hs @@ -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))