diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -6,6 +6,105 @@
## [Unreleased]
+## [4.0.0.0] - 2026-09-17
+
+### Fixed
+
+- A `{-# LINE n "file" #-}` pragma now applies its file name. The file name was
+ dropped for every well-formed LINE pragma, so spans after one kept the source
+ name the caller passed in while taking their line and column from the pragma.
+ The equivalent `#line` directive was already handled correctly.
+
+### Removed
+
+- The CPP preprocessor benchmark. `BENCHMARKS.md` no longer carries a "CPP
+ Performance" table comparing `aihc-cpp` against `clang -E` and `cpphs`, and
+ `aihc-parser-bench` no longer depends on `cpphs` or shells out to `clang`.
+ `aihc-cpp` is still used to preprocess the parser corpus before measurement;
+ only its benchmark is gone.
+
+### Changed
+
+- Remove the `NoSourceSpan` constructor and `noSourceSpan`. A `SourceSpan` is
+ now always a concrete span. Parsed syntax gets the span of the tokens it
+ consumed, or the zero-width span where the parser stands when it consumed
+ none. Every parse error has a span too: an error that names no token, such
+ as one raised with `fail`, is located at the token the parser stood on when
+ it was raised.
+- `sourceSpanSourceName` is now a `Text` rather than a `FilePath`. Callers
+ that read the field get a `Text`; callers that build a `SourceSpan` by hand
+ pass a `Text`. The name given as `parserSourceName` is still a `FilePath`
+ and is converted once when lexing starts.
+- `SourceSpan` is now a bidirectional record pattern synonym over a packed
+ representation. Constructing a span, matching on one, reading a field and
+ record-update syntax all work exactly as before. Two things change: import
+ it as `SourceSpan, pattern SourceSpan` plus the field names you use, since
+ `SourceSpan (..)` no longer brings the fields into scope, and the `Data`
+ instance sees three `Word64` fields rather than six `Int` ones.
+- `applyImpliedExtensions` returns its result in `Extension` constructor order
+ and without duplicates when it has anything to add, rather than in
+ most-recently-enabled-first order. Only membership was ever meaningful; a
+ list that is already closed is still returned untouched.
+
+### Performance
+
+- A `SourceSpan` holds its six positions in three unboxed `Word64` fields
+ rather than six `Int` ones, two positions to a word. It is the most numerous
+ object in a parse tree, so a third off its size shows up in peak heap as
+ well as in allocation.
+- Expression parsing dispatches the block forms (`do`, `mdo`, qualified `do`,
+ `if`, `case`, `let`, `proc`, `\`) and prefix negation on the next token
+ instead of trying them in turn. Each block form starts with its own
+ keyword, so at most one could ever match, but the old chain of alternatives
+ allocated a continuation for all nine plus a backtracking negation at every
+ expression position.
+- The type-atom parser's fallback branch tries only the three alternatives
+ whose leading token is not already dispatched, instead of re-running the
+ full eleven-way chain.
+- The implied-extension fixpoint runs on the `ExtensionSet` bitset instead of
+ on lists, so closing a set costs word operations rather than a `filter` per
+ implication and a pair of `sort`s per round. It ran once per file.
+
+Together these cut the `bench-aihc-base` benchmark's allocation by about 20%
+(2.93 GB to 2.34 GB over five iterations), its wall time by about 12%
+(152 ms to 134 ms per iteration) and its peak heap by about 20%
+(21.4 MB to 17.1 MB).
+
+A second round of the same kind:
+
+- The layout engine builds one `LayoutState` per token instead of several.
+ Its intermediate results were bound with lazy tuple patterns, so every token
+ of every file allocated a pair and a selector thunk per component of it
+ before anything was looked at. The emitted token list also skips its three
+ `(<>)` thunks in the usual case, where no virtual token was inserted.
+- Peeking at the next token is a Megaparsec primitive (`peekToken` and
+ friends) that reads the stream's memoized successor, rather than
+ `lookAhead anySingle`. Every dispatch point in the parser used the latter,
+ and paid for a state save and restore, the `token` machinery and a monadic
+ bind each time.
+- Optional tokens are decided on the peeked token — `optionalTok` for a token
+ on its own, `optionalTokThen` for one that introduces a parser — instead of
+ by running a parser and recovering from its failure. This replaced 45 uses
+ of `MP.optional (expectedTok …)`, including the record braces and record dot
+ that used to be tried after every atom in the file.
+- The infix-operator chain, parenthesized operator sections such as `(+)`, the
+ record-construction base and type applications as function arguments are all
+ now chosen on the next token rather than by trying and backtracking.
+- A pragma declaration is recognized from the pending-pragma list on the
+ parser state, so an ordinary declaration no longer starts with a failed
+ pragma parse.
+- A declaration that starts with a variable identifier only tries the pattern
+ binding parser when the token after it is `@`, a constructor operator or a
+ backtick. Nothing else can make such a declaration a pattern binding, and a
+ function definition with arguments is the most common declaration there is.
+- `label` is a primitive too: a successful parse now goes straight to the
+ caller's continuation, with no `Either` box from `MP.observing` and no bind,
+ and the found token comes from the state the failure happened in.
+
+Together these cut the benchmark's allocation by a further 19% (2.52 GB to
+2.05 GB over five iterations) and its wall time by about 11% (150 ms to
+134 ms per iteration), at unchanged peak heap.
+
## [3.0.1.1] - 2026-09-15
### Fixed
diff --git a/aihc-parser.cabal b/aihc-parser.cabal
--- a/aihc-parser.cabal
+++ b/aihc-parser.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.8
name: aihc-parser
-version: 3.0.1.1
+version: 4.0.0.0
build-type: Simple
license: Unlicense
license-file: LICENSE
diff --git a/src/Aihc/Parser.hs b/src/Aihc/Parser.hs
--- a/src/Aihc/Parser.hs
+++ b/src/Aihc/Parser.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
-- |
-- Module : Aihc.Parser
@@ -30,7 +31,7 @@
)
where
-import Aihc.Parser.Internal.Common (drainParseErrors, eofTok)
+import Aihc.Parser.Internal.Common (TokParser, drainParseErrors, eofTok)
import Aihc.Parser.Internal.Decl (declParser)
import Aihc.Parser.Internal.Errors (parseErrorBundleToSpannedText, parseErrorsToSpannedText)
import Aihc.Parser.Internal.Expr (exprParser)
@@ -38,7 +39,7 @@
import Aihc.Parser.Internal.Pattern (patternParser)
import Aihc.Parser.Internal.Type (typeParser, typeSignatureParser)
import Aihc.Parser.Pretty ()
-import Aihc.Parser.Syntax (Decl, Expr, Module (..), Pattern, SourceSpan (..), Type, applyImpliedExtensions)
+import Aihc.Parser.Syntax (Decl, Expr, Extension, Module (..), Pattern, SourceSpan, Type, applyImpliedExtensions, sourceSpanEndCol, sourceSpanSourceName, sourceSpanStartCol, sourceSpanStartLine, sourceSpanStartOffset, pattern SourceSpan)
import Aihc.Parser.Types
import Data.ByteString qualified as BS
import Data.List qualified as List
@@ -85,11 +86,7 @@
-- >>> case parseExpr defaultConfig "1 +" of { ParseErr _ -> "error"; ParseOk _ -> "ok" }
-- "error"
parseExpr :: ParserConfig -> Text -> ParseResult Expr
-parseExpr cfg input =
- let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input
- in case runTokStreamParser (exprParser <* eofTok) (parserSourceName cfg) ts of
- Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)
- Right expr -> ParseOk expr
+parseExpr = runEntry mkTokStream (exprParser <* eofTok)
-- | Parse a Haskell pattern.
--
@@ -99,11 +96,7 @@
-- >>> shorthand $ parsePattern defaultConfig "Just x"
-- ParseOk (PCon "Just" [PVar "x"])
parsePattern :: ParserConfig -> Text -> ParseResult Pattern
-parsePattern cfg input =
- let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input
- in case runTokStreamParser (patternParser <* eofTok) (parserSourceName cfg) ts of
- Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)
- Right pat -> ParseOk pat
+parsePattern = runEntry mkTokStream (patternParser <* eofTok)
-- | Parse a Haskell signature type.
--
@@ -113,11 +106,7 @@
-- >>> case parseSignatureType defaultConfig "_ :: _" of { ParseErr _ -> "error"; ParseOk _ -> "ok" }
-- "error"
parseSignatureType :: ParserConfig -> Text -> ParseResult Type
-parseSignatureType cfg input =
- let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input
- in case runTokStreamParser (typeSignatureParser <* eofTok) (parserSourceName cfg) ts of
- Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)
- Right ty -> ParseOk ty
+parseSignatureType = runEntry mkTokStream (typeSignatureParser <* eofTok)
-- | Parse a Haskell type in the general declaration RHS context.
--
@@ -130,22 +119,14 @@
-- >>> shorthand $ parseType defaultConfig "_ :: _"
-- ParseOk (TKindSig (TWildcard) (TWildcard))
parseType :: ParserConfig -> Text -> ParseResult Type
-parseType cfg input =
- let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input
- in case runTokStreamParser (typeParser <* eofTok) (parserSourceName cfg) ts of
- Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)
- Right ty -> ParseOk ty
+parseType = runEntry mkTokStream (typeParser <* eofTok)
-- | Parse a single Haskell declaration.
--
-- >>> shorthand $ parseDecl defaultConfig "f x = x + 1"
-- ParseOk (DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "x"], EInfix (EVar "x") "+" (EInt 1 TInteger)}]))
parseDecl :: ParserConfig -> Text -> ParseResult Decl
-parseDecl cfg input =
- let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input
- in case runTokStreamParser (declParser <* eofTok) (parserSourceName cfg) ts of
- Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)
- Right decl -> ParseOk decl
+parseDecl = runEntry mkTokStream (declParser <* eofTok)
-- | Parse a complete Haskell module.
--
@@ -162,25 +143,40 @@
-- Nothing
parseModule :: ParserConfig -> Text -> ([(SourceSpan, Text)], Module)
parseModule cfg input =
- let ts = mkTokStreamModule (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input
- parser = do
- modu <- moduleParser
- errs <- drainParseErrors
- pure (errs, modu)
- in case runTokStreamParser parser (parserSourceName cfg) ts of
- Left bundle ->
- ( parseErrorBundleToSpannedText bundle,
- Module
- { moduleAnns = [],
- moduleHead = Nothing,
- moduleLanguagePragmas = [],
- moduleImports = [],
- moduleDecls = []
- }
- )
- Right (errs, modu) ->
- (parseErrorsToSpannedText errs, modu)
+ case runTokStreamParser parser sourceName (mkTokStreamModule sourceName exts input) of
+ Left bundle ->
+ ( parseErrorBundleToSpannedText sourceName errorStream bundle,
+ Module
+ { moduleAnns = [],
+ moduleHead = Nothing,
+ moduleLanguagePragmas = [],
+ moduleImports = [],
+ moduleDecls = []
+ }
+ )
+ Right (errs, modu) ->
+ (parseErrorsToSpannedText sourceName errorStream errs, modu)
+ where
+ sourceName = parserSourceName cfg
+ exts = applyImpliedExtensions (parserExtensions cfg)
+ errorStream = rebuildStream (\(name, es, src) -> mkTokStreamModule name es src) (sourceName, exts, input)
+ parser = do
+ modu <- moduleParser
+ errs <- drainParseErrors
+ pure (errs, modu)
+-- | Run a parser over freshly lexed input. Errors are located on a stream
+-- built again from the input, so the parse itself does not retain the token
+-- chain (see 'rebuildStream').
+runEntry :: (FilePath -> [Extension] -> Text -> TokStream) -> TokParser a -> ParserConfig -> Text -> ParseResult a
+runEntry mkStream parser cfg input =
+ case runTokStreamParser parser sourceName (mkStream sourceName exts input) of
+ Left bundle -> ParseErr (parseErrorBundleToSpannedText sourceName (rebuildStream (\(name, es, src) -> mkStream name es src) (sourceName, exts, input)) bundle)
+ Right parsed -> ParseOk parsed
+ where
+ sourceName = parserSourceName cfg
+ exts = applyImpliedExtensions (parserExtensions cfg)
+
-- | Pretty-print a list of spanned parse errors with source context.
formatParseErrors :: FilePath -> Maybe Text -> [(SourceSpan, Text)] -> String
formatParseErrors sourceName mSource errs =
@@ -191,8 +187,8 @@
renderString
( layoutPretty opts $
case (srcSpan, mSource) of
- (ss@SourceSpan {}, Just source) ->
- vcat [renderSourceReference sourceName source ss, pretty msg]
+ (ss, Just source) ->
+ vcat [renderSourceReference source ss, pretty msg]
_ ->
vcat [pretty sourceName, pretty msg]
)
@@ -200,27 +196,20 @@
errs
in List.intercalate "\n\n" blocks
--- renderSourceReference "" "x = 1" (SourceSpan 1 5 1 6) = """
+-- renderSourceReference "x = 1" (SourceSpan "" 1 5 1 6 4 5) = """
-- :1:5:
-- 1 | x = 1
-- | ^
-- """
--- renderSourceReference "" "module where" (SourceSpan 1 8 1 13) = """
--- :1:5:
+-- renderSourceReference "module where" (SourceSpan "" 1 8 1 13 7 12) = """
+-- :1:8:
-- 1 | module where
-- | ^^^^^
-- """
-renderSourceReference :: String -> Text -> SourceSpan -> Doc ann
-renderSourceReference origin source srcSpan =
- let (renderedOrigin, lineNo, colNo, endCol, srcLine) = case srcSpan of
- SourceSpan {sourceSpanSourceName, sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndCol, sourceSpanStartOffset} ->
- ( sourceSpanSourceName,
- sourceSpanStartLine,
- sourceSpanStartCol,
- sourceSpanEndCol,
- extractSourceLineByOffset source sourceSpanStartOffset
- )
- NoSourceSpan -> (origin, 1, 1, 1, "")
+renderSourceReference :: Text -> SourceSpan -> Doc ann
+renderSourceReference source srcSpan =
+ let SourceSpan {sourceSpanSourceName = renderedOrigin, sourceSpanStartLine = lineNo, sourceSpanStartCol = colNo, sourceSpanEndCol = endCol, sourceSpanStartOffset} = srcSpan
+ srcLine = extractSourceLineByOffset source sourceSpanStartOffset
lineNoText = show lineNo
markerPrefix = replicate (length lineNoText) ' ' ++ " | "
markerStart = max 0 (colNo - 1)
diff --git a/src/Aihc/Parser/Internal/Cmd.hs b/src/Aihc/Parser/Internal/Cmd.hs
--- a/src/Aihc/Parser/Internal/Cmd.hs
+++ b/src/Aihc/Parser/Internal/Cmd.hs
@@ -12,7 +12,7 @@
import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind)
import Aihc.Parser.Syntax
import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)
-import Text.Megaparsec (anySingle, lookAhead, (<|>))
+import Text.Megaparsec ((<|>))
import Text.Megaparsec qualified as MP
-- | Parse a command (the body of a @proc@ abstraction).
@@ -27,7 +27,7 @@
-- @
cmdParser :: TokParser Cmd
cmdParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordDo -> cmd0Parser
TkKeywordIf -> cmd0Parser
@@ -52,7 +52,7 @@
cmd10Parser :: TokParser Cmd
cmd10Parser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordDo -> cmdDoParser
TkKeywordIf -> cmdIfParser
@@ -145,7 +145,7 @@
-- | Parse a do-statement in command context (arrow do).
cmdStmtParser :: TokParser (DoStmt Cmd)
cmdStmtParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordLet -> MP.try cmdLetStmtParser <|> cmdBodyStmtParser
TkKeywordRec -> cmdRecStmtParser
@@ -174,17 +174,17 @@
cmdBindOrBodyStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do
-- Arrow tails (-<, -<<) belong to the command level, not the expression.
expr <- exprParser
- mArrow <- MP.optional (expectedTok TkReservedLeftArrow)
- case mArrow of
- Just () -> DoBind <$> liftCheck (checkPattern expr) <*> cmdParser
- Nothing -> do
+ hasArrow <- optionalTok TkReservedLeftArrow
+ if hasArrow
+ then DoBind <$> liftCheck (checkPattern expr) <*> cmdParser
+ else do
-- No bind arrow: this is a body statement. Check for arrow tail.
mArrTail <- MP.optional cmdArrTailParser
case mArrTail of
Just (appType, rhs) ->
pure (DoExpr (CmdArrApp expr appType rhs))
Nothing -> do
- mTok <- MP.optional (lookAhead anySingle)
+ mTok <- peekTokenMaybe
MP.customFailure
UnexpectedTokenExpecting
{ unexpectedFound = mkFoundToken <$> mTok,
diff --git a/src/Aihc/Parser/Internal/Common.hs b/src/Aihc/Parser/Internal/Common.hs
--- a/src/Aihc/Parser/Internal/Common.hs
+++ b/src/Aihc/Parser/Internal/Common.hs
@@ -5,6 +5,13 @@
label,
region,
expectedTok,
+ peekToken,
+ peekTokenMaybe,
+ peekTokenKind,
+ nextTokenIs,
+ tokenKindDispatch,
+ optionalTok,
+ optionalTokThen,
eofTok,
varIdTok,
tokenSatisfy,
@@ -32,6 +39,7 @@
operatorTextParser,
constructorInfixOperatorNameParser,
stringTextParser,
+ consumedSpan,
inputStartSpan,
withSpan,
withSpanAnn,
@@ -72,6 +80,7 @@
isConLikeNameType,
liftCheck,
infixOperatorParser,
+ startsInfixOperator,
foldInfixL,
foldInfixR,
)
@@ -79,7 +88,7 @@
import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), TokenOrigin (..), closeImplicitLayoutContext)
import Aihc.Parser.Syntax
-import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, tokStreamExtensionSet)
+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, sourcePosSpan, tokStreamExtensionSet)
import Control.Monad (guard)
import Data.Char (isUpper)
import Data.Functor (($>))
@@ -91,32 +100,43 @@
import Text.Megaparsec (Parsec, anySingle, lookAhead, (<|>))
import Text.Megaparsec qualified as MP
import Text.Megaparsec.Error qualified as MPE
+import Text.Megaparsec.Internal qualified as MPI
type TokParser = Parsec ParserErrorComponent TokStream
+-- | Replace whatever error a parser reports with one that names what was
+-- expected here and what was found instead.
+--
+-- Written as a primitive rather than as 'MP.observing' followed by a case:
+-- the labelled parsers are the hot ones — every expression, every right-hand
+-- side, every type — and this way a successful parse hands its result
+-- straight to the caller's continuation, with no 'Either' box and no bind.
+-- The failure continuations see the state the failure happened in, so the
+-- token that was found is read from that state rather than looked ahead for.
label :: Text -> TokParser a -> TokParser a
-label expected parser = do
- outcome <- MP.observing parser
- case outcome of
- Right parsed -> pure parsed
- Left err ->
+label expected parser =
+ MPI.ParsecT $ \s cok cerr eok eerr ->
+ MPI.unParser parser s cok (relabel cerr) eok (relabel eerr)
+ where
+ relabel report err errState =
case err of
- MPE.TrivialError off _ _ -> do
- mTok <- MP.optional (lookAhead anySingle)
- let mFound = mkFoundToken <$> mTok
- MP.parseError $
- MPE.FancyError
- off
- ( Set.singleton
- ( MPE.ErrorCustom
- UnexpectedTokenExpecting
- { unexpectedFound = mFound,
- unexpectedExpecting = expected,
- unexpectedContext = []
- }
- )
- )
- _ -> MP.parseError err
+ MPE.TrivialError off _ _ ->
+ report
+ ( MPE.FancyError
+ off
+ ( Set.singleton
+ ( MPE.ErrorCustom
+ UnexpectedTokenExpecting
+ { unexpectedFound =
+ mkFoundToken . fst <$> tokStreamNext (MP.stateInput errState),
+ unexpectedExpecting = expected,
+ unexpectedContext = []
+ }
+ )
+ )
+ )
+ errState
+ _ -> report err errState
region :: Text -> TokParser a -> TokParser a
region context =
@@ -142,6 +162,84 @@
if lexTokenKind tok == expected then Just () else Nothing
{-# INLINE expectedTok #-}
+-- | The next token, without consuming it.
+--
+-- Fails at the end of the stream with the same error as @lookAhead
+-- anySingle@, which is what every dispatch point used before: this is that
+-- parser with the 'MP.lookAhead' state save and restore and the 'MP.token'
+-- machinery replaced by a read of the stream's memoized successor.
+peekToken :: TokParser LexToken
+peekToken =
+ MPI.ParsecT $ \s _ _ eok eerr ->
+ case tokStreamNext (MP.stateInput s) of
+ Just (tok, _) -> eok tok s mempty
+ Nothing -> eerr (MPE.TrivialError (MP.stateOffset s) (Just MPE.EndOfInput) Set.empty) s
+{-# INLINE peekToken #-}
+
+-- | The next token, or 'Nothing' at the end of the stream.
+peekTokenMaybe :: TokParser (Maybe LexToken)
+peekTokenMaybe =
+ MPI.ParsecT $ \s _ _ eok _ ->
+ eok (fst <$> tokStreamNext (MP.stateInput s)) s mempty
+{-# INLINE peekTokenMaybe #-}
+
+-- | The kind of the next token, without consuming it and without building a
+-- parse error when there is none.
+peekTokenKind :: TokParser (Maybe LexTokenKind)
+peekTokenKind = MPI.ParsecT $ \s _ _ eok _ -> eok (nextTokenKind s) s mempty
+{-# INLINE peekTokenKind #-}
+
+-- | Whether the next token has the given kind, without consuming it.
+nextTokenIs :: LexTokenKind -> TokParser Bool
+nextTokenIs expected =
+ MPI.ParsecT $ \s _ _ eok _ -> eok (nextTokenKind s == Just expected) s mempty
+{-# INLINE nextTokenIs #-}
+
+-- | Run the parser that the next token's kind selects.
+--
+-- 'Nothing' means the stream is exhausted, which only happens once 'TkEOF'
+-- has been consumed.
+tokenKindDispatch :: (Maybe LexTokenKind -> TokParser a) -> TokParser a
+tokenKindDispatch select =
+ MPI.ParsecT $ \s cok cerr eok eerr ->
+ MPI.unParser (select (nextTokenKind s)) s cok cerr eok eerr
+{-# INLINE tokenKindDispatch #-}
+
+nextTokenKind :: MP.State TokStream e -> Maybe LexTokenKind
+nextTokenKind s =
+ case tokStreamNext (MP.stateInput s) of
+ Just (tok, _) -> Just (lexTokenKind tok)
+ Nothing -> Nothing
+{-# INLINE nextTokenKind #-}
+
+-- | Consume the next token if it has the given kind, reporting whether it
+-- did.
+--
+-- Behaves exactly like @MP.optional (expectedTok expected)@ — including at
+-- the end of the stream, where both leave the input alone — but decides on
+-- the peeked token instead of recovering from a failed parse.
+optionalTok :: LexTokenKind -> TokParser Bool
+optionalTok expected =
+ tokenKindDispatch $ \mKind ->
+ if mKind == Just expected
+ then True <$ expectedTok expected
+ else pure False
+{-# INLINE optionalTok #-}
+
+-- | Like @MP.optional (expectedTok expected *> parser)@, but decided on the
+-- peeked token.
+--
+-- The behaviour is identical, including when @parser@ fails after the token
+-- was consumed: the failure propagates, because input was consumed either
+-- way. Pass @pure ()@ for a bare optional token.
+optionalTokThen :: LexTokenKind -> TokParser a -> TokParser (Maybe a)
+optionalTokThen expected parser =
+ tokenKindDispatch $ \mKind ->
+ if mKind == Just expected
+ then Just <$> (expectedTok expected *> parser)
+ else pure Nothing
+{-# INLINE optionalTokThen #-}
+
-- | Match the end-of-file token.
--
-- The lexer emits a 'TkEOF' token at the end of input. This parser consumes
@@ -463,35 +561,72 @@
TkString txt -> Just txt
_ -> Nothing
-withSpanAnn :: (SourceSpan -> a -> a) -> TokParser a -> TokParser a
+-- | The span of the tokens consumed between two stream positions, each given
+-- as the stream and its offset: from the first token at the start position to
+-- the last token consumed before the end position. The result is lazy in both
+-- positions, so a caller can attach the span of a deferred parse (see 'lazy')
+-- without forcing that parse.
+--
+-- A parser that consumed nothing gets the zero-width span at the point where
+-- it stands. A stream with no tokens at all has no token to stand at; the
+-- lexer never builds one, since it always ends the stream with 'TkEOF', but a
+-- stream built from an explicit token list can be empty. The span is then the
+-- zero-width span at the given start of the input, which the parser state
+-- knows along with the source name.
+consumedSpan :: MP.SourcePos -> TokStream -> Int -> TokStream -> Int -> SourceSpan
+consumedSpan inputStart startInput startOffset endInput endOffset =
+ case (inputStartSpan startInput, lexTokenSpan <$> tokStreamPrevToken endInput) of
+ (Just next, Just prev)
+ | endOffset > startOffset -> mergeSourceSpans next prev
+ | otherwise -> emptySpanAtStart next
+ (Just next, Nothing) -> emptySpanAtStart next
+ (Nothing, Just prev) -> emptySpanAtEnd prev
+ (Nothing, Nothing) -> sourcePosSpan inputStart
+ where
+ emptySpanAtStart sp =
+ sp
+ { sourceSpanEndLine = sourceSpanStartLine sp,
+ sourceSpanEndCol = sourceSpanStartCol sp,
+ sourceSpanEndOffset = sourceSpanStartOffset sp
+ }
+ emptySpanAtEnd sp =
+ sp
+ { sourceSpanStartLine = sourceSpanEndLine sp,
+ sourceSpanStartCol = sourceSpanEndCol sp,
+ sourceSpanStartOffset = sourceSpanEndOffset sp
+ }
+
+-- | Run a parser and combine its result with the span of the consumed tokens.
+--
+-- The parser state is read once at each end, and the fields the span needs
+-- are taken out strictly, so the span thunk holds positions rather than the
+-- state. The state's position state references the initial input, and holding
+-- it would keep every token of the file alive until the tree is forced.
+withSpanAnn :: (SourceSpan -> a -> b) -> TokParser a -> TokParser b
withSpanAnn f parser = do
- startInput <- MP.getInput
+ startState <- MP.getParserState
+ let !startInput = MP.stateInput startState
+ !startOffset = MP.stateOffset startState
+ !inputStart = MP.pstateSourcePos (MP.statePosState startState)
out <- parser
- endInput <- MP.getInput
- let startSpan = inputStartSpan startInput
- endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)
- parserSpan = mergeSourceSpans startSpan endSpan
- pure $ f parserSpan out
+ endState <- MP.getParserState
+ let !endInput = MP.stateInput endState
+ !endOffset = MP.stateOffset endState
+ pure (f (consumedSpan inputStart startInput startOffset endInput endOffset) out)
{-# INLINE withSpanAnn #-}
--- FIXME: Remove.
+-- | Run a parser whose result takes the span of the consumed tokens.
withSpan :: TokParser (SourceSpan -> a) -> TokParser a
-withSpan parser = do
- startInput <- MP.getInput
- out <- parser
- endInput <- MP.getInput
- let startSpan = inputStartSpan startInput
- endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)
- parserSpan = mergeSourceSpans startSpan endSpan
- pure (out parserSpan)
+withSpan = withSpanAnn (\parserSpan out -> out parserSpan)
{-# INLINE withSpan #-}
-inputStartSpan :: TokStream -> SourceSpan
+-- | The span of the next token, if there is one.
+inputStartSpan :: TokStream -> Maybe SourceSpan
inputStartSpan ts
- | tokStreamEOFEmitted ts = noSourceSpan
- | tok : _ <- tokStreamBuffer ts = lexTokenSpan tok
- | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok
- | otherwise = noSourceSpan
+ | tokStreamEOFEmitted ts = Nothing
+ | tok : _ <- tokStreamBuffer ts = Just (lexTokenSpan tok)
+ | rawTok : _ <- tokStreamRawTokens ts = Just (lexTokenSpan rawTok)
+ | otherwise = Nothing
{-# INLINE inputStartSpan #-}
optionalSuffix :: TokParser b -> (a -> b -> a) -> TokParser a -> TokParser a
@@ -678,7 +813,7 @@
first <- constraintTypeAppParser
rest <- MP.many ((,) <$> constraintTypeInfixOperatorParser <*> constraintTypeAppParser)
let baseType = foldInfixR buildInfixType first rest
- mRhs <- MP.optional (expectedTok TkReservedRightArrow *> kindTypeParser)
+ mRhs <- optionalTokThen TkReservedRightArrow kindTypeParser
case mRhs of
Just rhs ->
pure (TFun ArrowUnrestricted baseType rhs)
@@ -719,13 +854,19 @@
contextItemsParserWith typeParser typeAtomParser =
MP.try parenthesizedContextItemsParser <|> fmap pure (contextItemParserWith typeParser typeAtomParser)
where
- parenthesizedContextItemsParser = do
+ parenthesizedContextItemsParser = withSpanAnn annotateSingleItem $ do
items <- parens (listContextItemParser `MP.sepEndBy` expectedTok TkSpecialComma)
guardNotFollowedByConstraintInfixOp
case items of
[] -> fail "empty constraint list in parens"
- [item] -> pure [typeAnnSpan NoSourceSpan (TParen item)]
+ [item] -> pure [TParen item]
_ -> pure items
+ -- A single item keeps its parentheses as a node that spans the whole
+ -- parenthesized list.
+ annotateSingleItem sp items =
+ case items of
+ [item] -> [typeAnnSpan sp item]
+ _ -> items
listContextItemParser =
MP.try quantifiedContextItemParser <|> contextItemParserWith typeParser typeAtomParser
-- \| Extension form (QuantifiedConstraints):
@@ -816,7 +957,7 @@
TokParser a
typedBindingOrSignatureParser typeParser signatureCtor bindingCtor singleBinderMsg = do
(names, ty) <- typedSignaturePrefixParser typeParser
- nextKind <- lexTokenKind <$> lookAhead anySingle
+ nextKind <- lexTokenKind <$> peekToken
if nextKind == TkReservedEquals || nextKind == TkReservedPipe
then case names of
[name] -> bindingCtor name ty
@@ -972,11 +1113,11 @@
fields <- fieldsParser
if rwcEnabled
then do
- mDotDot <- MP.optional (expectedTok TkReservedDotDot)
- case mDotDot of
- Nothing -> pure (fields, False)
- Just _ -> do
- _ <- MP.optional (expectedTok TkSpecialComma)
+ hasDotDot <- optionalTok TkReservedDotDot
+ if not hasDotDot
+ then pure (fields, False)
+ else do
+ _ <- optionalTok TkSpecialComma
pure (fields, True)
else pure (fields, False)
@@ -1200,6 +1341,21 @@
liftCheck :: Either Text a -> TokParser a
liftCheck (Right a) = pure a
liftCheck (Left msg) = fail (T.unpack msg)
+
+-- | Whether a token can start an infix operator, symbolic or backticked.
+-- Mirrors the token cases of 'infixOperatorParser'.
+startsInfixOperator :: LexTokenKind -> Bool
+startsInfixOperator kind =
+ case kind of
+ TkVarSym {} -> True
+ TkConSym {} -> True
+ TkPrefixPercent -> True
+ TkQVarSym {} -> True
+ TkQConSym {} -> True
+ TkMinusOperator -> True
+ TkReservedColon -> True
+ TkSpecialBacktick -> True
+ _ -> False
-- | Parse an infix operator.
infixOperatorParser :: TokParser Name
diff --git a/src/Aihc/Parser/Internal/Decl.hs b/src/Aihc/Parser/Internal/Decl.hs
--- a/src/Aihc/Parser/Internal/Decl.hs
+++ b/src/Aihc/Parser/Internal/Decl.hs
@@ -16,11 +16,11 @@
import Aihc.Parser.Internal.Type (arrowKindParser, forallTelescopeParser, typeAppParser, typeAtomParser, typeInfixOperatorParser, typeInfixParser, typeParser, typeSignatureParser)
import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, pattern TkVarFamily, pattern TkVarRole)
import Aihc.Parser.Syntax
-import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)
+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken)
import Control.Monad (when)
import Data.Char (isLower)
import Data.Functor (($>))
-import Data.Maybe (fromMaybe, isJust)
+import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Text.Megaparsec (anySingle, lookAhead, (<|>))
@@ -39,8 +39,16 @@
--
-- > decl -> gendecl
-- > | (funlhs | pat) rhs
+-- | A pragma declaration is only possible when the lexer has actually set a
+-- hidden pragma aside, so the state says so directly. Trying
+-- 'pragmaDeclParser' first instead made every ordinary declaration pay for a
+-- parser failure, with the error and hints that go with it.
declParser :: TokParser Decl
-declParser = pragmaDeclParser <|> ordinaryDeclParser
+declParser = do
+ pst <- MP.getParserState
+ case tokStreamPendingPragmas (MP.stateInput pst) of
+ [] -> ordinaryDeclParser
+ _ -> pragmaDeclParser <|> ordinaryDeclParser
ordinaryDeclParser :: TokParser Decl
ordinaryDeclParser = do
@@ -94,9 +102,32 @@
TkReservedDoubleColon -> sigOrValueDecl
TkSpecialComma -> sigOrValueDecl
TkReservedEquals -> valueDecl
- _ -> nonBareVarPatternBindDeclParser <|> valueDecl
+ _
+ | patternBindMayFollowVarId nextTokKind ->
+ nonBareVarPatternBindDeclParser <|> valueDecl
+ | otherwise -> valueDecl
_ -> fallbackDecl
+-- | Whether a declaration whose first token is a variable identifier can
+-- still be a pattern binding, given the token after it.
+--
+-- A variable identifier on its own is a bare variable pattern, which
+-- 'nonBareVarPatternBindDeclParser' rejects, so the only pattern bindings
+-- that start with one are an as-pattern (@x\@p = ...@) and an infix
+-- constructor pattern (@x : xs = ...@, @x \`Cons\` y = ...@). Every other
+-- second token means the declaration is a function binding, and trying the
+-- pattern parser first only to backtrack was pure cost: a function
+-- definition with arguments is the most common declaration there is.
+patternBindMayFollowVarId :: LexTokenKind -> Bool
+patternBindMayFollowVarId kind =
+ case kind of
+ TkReservedAt -> True
+ TkConSym {} -> True
+ TkQConSym {} -> True
+ TkReservedColon -> True
+ TkSpecialBacktick -> True
+ _ -> False
+
-- | Like 'patternBindDeclParser' but rejects bare variable patterns.
-- When the leading token is a variable identifier, a bare @x = 5@ must be
-- parsed as a zero-argument function bind, not a pattern bind. This parser
@@ -215,7 +246,7 @@
)
<|> do
(context, head') <- declHeadWithOptionalContext headParser
- inlineKind <- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)
+ inlineKind <- optionalTokThen TkReservedDoubleColon typeParser
pure (context, head', inlineKind)
-- | Parse a declaration head that may be preceded by a context.
@@ -240,7 +271,7 @@
-- | Parse an optional unnamed @:: Kind@ result signature for a family head.
familyResultKindParser :: TokParser (Maybe Type)
familyResultKindParser =
- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)
+ optionalTokThen TkReservedDoubleColon typeParser
-- | Parse an optional type family result signature. GHC admits either an unnamed
-- @:: Kind@ annotation or a named result variable with optional injectivity annotation,
@@ -474,7 +505,7 @@
instanceTypeFamilyInstParser :: TokParser InstanceDeclItem
instanceTypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do
expectedTok TkKeywordType
- _ <- MP.optional (expectedTok TkKeywordInstance)
+ _ <- optionalTok TkKeywordInstance
forallBinders <- MP.option [] explicitForallParser
(headForm, lhs) <- typeFamilyLhsParser
expectedTok TkReservedEquals
@@ -493,7 +524,7 @@
instanceDataFamilyInstParser :: TokParser InstanceDeclItem
instanceDataFamilyInstParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do
expectedTok TkKeywordData
- _ <- MP.optional (expectedTok TkKeywordInstance)
+ _ <- optionalTok TkKeywordInstance
(_, head') <- typeFamilyLhsParser
kind <- familyResultKindParser
(constructors, derivingClauses) <- gadtDataDeclParser <|> traditionalDataDeclParser
@@ -513,7 +544,7 @@
instanceNewtypeFamilyInstParser :: TokParser InstanceDeclItem
instanceNewtypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkAnnotation) $ do
expectedTok TkKeywordNewtype
- _ <- MP.optional (expectedTok TkKeywordInstance)
+ _ <- optionalTok TkKeywordInstance
(_, head') <- typeFamilyLhsParser
kind <- familyResultKindParser
expectedTok TkReservedEquals
@@ -769,7 +800,7 @@
instanceDeclItemParser =
instancePragmaItemParser
<|> do
- tok <- lookAhead anySingle
+ tok <- peekToken
typeSigPrefix <- startsWithTypeSig
case lexTokenKind tok of
TkKeywordInfix -> instanceFixityItemParser
@@ -868,7 +899,7 @@
traditionalDataDeclParser :: TokParser ([DataConDecl], [DerivingClause])
traditionalDataDeclParser = do
- constructors <- MP.optional (expectedTok TkReservedEquals *> dataConDeclParser `MP.sepBy1` expectedTok TkReservedPipe)
+ constructors <- optionalTokThen TkReservedEquals (dataConDeclParser `MP.sepBy1` expectedTok TkReservedPipe)
derivingClauses <- MP.many derivingClauseParser
pure (fromMaybe [] constructors, derivingClauses)
@@ -912,7 +943,7 @@
-- type data may not have a datatype context
typeHead <- typeDeclHeadParser
-- Parse optional inline kind signature: @:: Kind@
- inlineKind <- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)
+ inlineKind <- optionalTokThen TkReservedDoubleColon typeParser
-- GADT syntax starts with `where`, traditional syntax starts with `=` or nothing
constructors <- gadtStyleTypeDataDecl <|> traditionalStyleTypeDataDecl
-- type data may not have a deriving clause
@@ -928,18 +959,18 @@
}
where
traditionalStyleTypeDataDecl =
- fromMaybe [] <$> MP.optional (expectedTok TkReservedEquals *> typeDataConDeclParser `MP.sepBy1` expectedTok TkReservedPipe)
+ fromMaybe [] <$> optionalTokThen TkReservedEquals (typeDataConDeclParser `MP.sepBy1` expectedTok TkReservedPipe)
gadtStyleTypeDataDecl = gadtTypeDataWhereClauseParser
-- | Parse constructors for type data (traditional style, after `=`)
-- No labelled fields, no strictness annotations
typeDataConDeclParser :: TokParser DataConDecl
-typeDataConDeclParser = withSpan $ do
+typeDataConDeclParser = withSpanAnn (DataConAnn . mkAnnotation) $ do
(_forallVars, context) <- dataConQualifiersParser
MP.try (typeDataConPrefixParser context) <|> typeDataConInfixParser context
-typeDataConPrefixParser :: [Type] -> TokParser (SourceSpan -> DataConDecl)
+typeDataConPrefixParser :: [Type] -> TokParser DataConDecl
typeDataConPrefixParser context = do
conName <- constructorUnqualifiedNameParser <|> parens constructorOperatorUnqualifiedNameParser
-- Parse arguments (no strictness, no records).
@@ -948,14 +979,13 @@
args <- MP.many $ BangType [] [] False False <$> typeAtomParser
-- If a constructor operator follows, this declaration is actually infix.
MP.notFollowedBy constructorOperatorParser
- pure $ \span' -> DataConAnn (mkAnnotation span') (PrefixCon [] context conName args)
+ pure (PrefixCon [] context conName args)
-typeDataConInfixParser :: [Type] -> TokParser (SourceSpan -> DataConDecl)
+typeDataConInfixParser :: [Type] -> TokParser DataConDecl
typeDataConInfixParser context = do
lhs <- typeDataConArgParser
op <- constructorOperatorUnqualifiedNameParser <|> backtickConstructorUnqualifiedParser
- rhs <- typeDataConArgParser
- pure $ \span' -> DataConAnn (mkAnnotation span') (InfixCon [] context lhs op rhs)
+ InfixCon [] context lhs op <$> typeDataConArgParser
where
backtickConstructorUnqualifiedParser = do
expectedTok TkSpecialBacktick
@@ -974,7 +1004,7 @@
-- | Parse a GADT constructor for type data
-- Only equality constraints permitted, no strictness, no records
gadtTypeDataConDeclParser :: TokParser DataConDecl
-gadtTypeDataConDeclParser = withSpan $ do
+gadtTypeDataConDeclParser = withSpanAnn (DataConAnn . mkAnnotation) $ do
-- Parse constructor names (can be multiple separated by commas)
names <- gadtConNameParser `MP.sepBy1` expectedTok TkSpecialComma
expectedTok TkReservedDoubleColon
@@ -983,8 +1013,7 @@
-- Parse context (only equality constraints permitted, but we parse generally)
context <- contextPrefixDispatchList
-- Parse the body (prefix only for type data - no record style)
- body <- gadtTypeDataBodyParser
- pure $ \span' -> DataConAnn (mkAnnotation span') (GadtCon forallBinders context names body)
+ GadtCon forallBinders context names <$> gadtTypeDataBodyParser
-- | Parse the body of a GADT constructor for type data
-- Only prefix style allowed (no records), no strictness annotations
@@ -1005,9 +1034,9 @@
in pure (GadtPrefixBody argsWithKinds resultTy)
dataConDeclParser :: TokParser DataConDecl
-dataConDeclParser = withSpan $ do
+dataConDeclParser = withSpanAnn (DataConAnn . mkAnnotation) $ do
(forallVars, context) <- dataConQualifiersParser
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
-- `(#` is either the LHS arg of an infix constructor (e.g. @(# #) :. Int@) or a
-- standalone unboxed tuple/sum constructor (e.g. @(# Int, Bool #)@).
@@ -1025,20 +1054,19 @@
<|> MP.try (boxedTupleConDeclParser forallVars context)
<|> dataConRecordOrPrefixParser forallVars context
-listConDeclParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)
+listConDeclParser :: [TyVarBinder] -> [Type] -> TokParser DataConDecl
listConDeclParser forallVars context = do
expectedTok TkSpecialLBracket
expectedTok TkSpecialRBracket
- pure $ \span' -> DataConAnn (mkAnnotation span') (ListCon forallVars context)
+ pure (ListCon forallVars context)
-boxedTupleConDeclParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)
+boxedTupleConDeclParser :: [TyVarBinder] -> [Type] -> TokParser DataConDecl
boxedTupleConDeclParser forallVars context = do
expectedTok TkSpecialLParen
- mClose <- MP.optional (expectedTok TkSpecialRParen)
- case mClose of
- Just () ->
- pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Boxed [])
- Nothing -> do
+ closedImmediately <- optionalTok TkSpecialRParen
+ if closedImmediately
+ then pure (TupleCon forallVars context Boxed [])
+ else do
firstField <- constructorArgParser
-- A comma is mandatory: boxed 1-tuples don't exist in Haskell
-- (e.g. @data C = (Int)@ is invalid). Without this, a
@@ -1047,16 +1075,15 @@
expectedTok TkSpecialComma
rest <- constructorArgParser `MP.sepBy1` expectedTok TkSpecialComma
expectedTok TkSpecialRParen
- pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Boxed (firstField : rest))
+ pure (TupleCon forallVars context Boxed (firstField : rest))
-unboxedConDeclParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)
+unboxedConDeclParser :: [TyVarBinder] -> [Type] -> TokParser DataConDecl
unboxedConDeclParser forallVars context = do
expectedTok TkSpecialUnboxedLParen
- mClose <- MP.optional (expectedTok TkSpecialUnboxedRParen)
- case mClose of
- Just () ->
- pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Unboxed [])
- Nothing -> do
+ closedImmediately <- optionalTok TkSpecialUnboxedRParen
+ if closedImmediately
+ then pure (TupleCon forallVars context Unboxed [])
+ else do
leadingPipes <- MP.many (MP.try (expectedTok TkReservedPipe))
if not (null leadingPipes)
then do
@@ -1065,23 +1092,23 @@
expectedTok TkSpecialUnboxedRParen
let pos = length leadingPipes + 1
arity = length leadingPipes + 1 + length trailingPipes
- pure $ \span' -> DataConAnn (mkAnnotation span') (UnboxedSumCon forallVars context pos arity field)
+ pure (UnboxedSumCon forallVars context pos arity field)
else do
firstField <- constructorArgParser
mSep <- MP.optional (MP.try ((Left () <$ expectedTok TkSpecialComma) <|> (Right () <$ expectedTok TkReservedPipe)))
case mSep of
Nothing -> do
expectedTok TkSpecialUnboxedRParen
- pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Unboxed [firstField])
+ pure (TupleCon forallVars context Unboxed [firstField])
Just (Left ()) -> do
rest <- constructorArgParser `MP.sepBy1` expectedTok TkSpecialComma
expectedTok TkSpecialUnboxedRParen
- pure $ \span' -> DataConAnn (mkAnnotation span') (TupleCon forallVars context Unboxed (firstField : rest))
+ pure (TupleCon forallVars context Unboxed (firstField : rest))
Just (Right ()) -> do
trailingPipes <- MP.many (expectedTok TkReservedPipe)
expectedTok TkSpecialUnboxedRParen
let arity = 1 + 1 + length trailingPipes
- pure $ \span' -> DataConAnn (mkAnnotation span') (UnboxedSumCon forallVars context 1 arity firstField)
+ pure (UnboxedSumCon forallVars context 1 arity firstField)
-- | Report core:
--
@@ -1105,7 +1132,7 @@
}
where
traditionalStyleNewtypeDecl = do
- constructor <- MP.optional (expectedTok TkReservedEquals *> dataConDeclParser)
+ constructor <- optionalTokThen TkReservedEquals dataConDeclParser
derivingClauses <- MP.many derivingClauseParser
pure (constructor, derivingClauses)
@@ -1124,7 +1151,7 @@
-- | Parse a GADT constructor declaration: @Con1, Con2 :: forall a. Ctx => Type@
gadtConDeclParser :: TokParser DataConDecl
-gadtConDeclParser = withSpan $ do
+gadtConDeclParser = withSpanAnn (DataConAnn . mkAnnotation) $ do
-- Parse constructor names (can be multiple separated by commas)
names <- gadtConNameParser `MP.sepBy1` expectedTok TkSpecialComma
expectedTok TkReservedDoubleColon
@@ -1133,8 +1160,7 @@
-- Parse optional context
context <- contextPrefixDispatchList
-- Parse the body (record or prefix style)
- body <- gadtBodyParser
- pure $ \span' -> DataConAnn (mkAnnotation span') (GadtCon forallBinders context names body)
+ GadtCon forallBinders context names <$> gadtBodyParser
-- | Parse constructor name for GADT - can be regular or operator in parens
gadtConNameParser :: TokParser UnqualifiedName
@@ -1407,7 +1433,7 @@
expectedTok TkKeywordType
explicitFamilyKeyword <- case familyKeywordMode of
FamilyKeywordRequired -> expectedTok TkVarFamily $> True
- FamilyKeywordOptional -> isJust <$> MP.optional (expectedTok TkVarFamily)
+ FamilyKeywordOptional -> optionalTok TkVarFamily
(headForm, headType, params) <- typeFamilyHeadParser
resultSig <- typeFamilyResultSigParser explicitFamilyKeyword
equations <-
@@ -1431,19 +1457,19 @@
expectedTok (TkVarSym ".")
pure binders
-dataConRecordOrPrefixParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)
+dataConRecordOrPrefixParser :: [TyVarBinder] -> [Type] -> TokParser DataConDecl
dataConRecordOrPrefixParser forallVars context = do
name <- constructorUnqualifiedNameParser <|> parens operatorUnqualifiedNameParser
mRecordFields <- MP.optional (MP.try recordFieldsParserAfterLayoutSemicolon)
case mRecordFields of
- Just fields -> pure (\span' -> DataConAnn (mkAnnotation span') (RecordCon forallVars context name fields))
+ Just fields -> pure (RecordCon forallVars context name fields)
Nothing -> do
args <- MP.many constructorArgParser
-- Ensure we're not leaving a constructor operator unconsumed.
-- If there's a constructor operator next, this is actually an infix form
-- and we should backtrack to let dataConInfixParser handle it.
MP.notFollowedBy constructorOperatorParser
- pure (\span' -> DataConAnn (mkAnnotation span') (PrefixCon forallVars context name args))
+ pure (PrefixCon forallVars context name args)
where
-- Layout may inject a virtual ';' before a newline-started record field block.
-- Accept it as part of the constructor declaration.
@@ -1451,12 +1477,11 @@
recordFieldsParser
<|> (expectedTok TkSpecialSemicolon *> recordFieldsParser)
-dataConInfixParser :: [TyVarBinder] -> [Type] -> TokParser (SourceSpan -> DataConDecl)
+dataConInfixParser :: [TyVarBinder] -> [Type] -> TokParser DataConDecl
dataConInfixParser forallVars context = do
lhs <- infixConstructorArgParser
op <- constructorOperatorUnqualifiedNameParser <|> backtickConstructorUnqualifiedParser
- rhs <- infixConstructorArgParser
- pure (\span' -> DataConAnn (mkAnnotation span') (InfixCon forallVars context lhs op rhs))
+ InfixCon forallVars context lhs op <$> infixConstructorArgParser
where
backtickConstructorUnqualifiedParser = do
expectedTok TkSpecialBacktick
@@ -1647,7 +1672,7 @@
Just matches -> pure (PatSynExplicitBidirectional matches, pat)
)
<|> do
- mTok <- MP.optional (lookAhead anySingle)
+ mTok <- peekTokenMaybe
MP.customFailure
UnexpectedTokenExpecting
{ unexpectedFound = mkFoundToken <$> mTok,
diff --git a/src/Aihc/Parser/Internal/Errors.hs b/src/Aihc/Parser/Internal/Errors.hs
--- a/src/Aihc/Parser/Internal/Errors.hs
+++ b/src/Aihc/Parser/Internal/Errors.hs
@@ -5,8 +5,8 @@
where
import Aihc.Parser.Lex (LexToken (..), TokenOrigin (..))
-import Aihc.Parser.Syntax (SourceSpan (..))
-import Aihc.Parser.Types (FoundToken (..), ParseErrorBundle, ParserErrorComponent (..), TokStream)
+import Aihc.Parser.Syntax (SourceSpan, sourceSpanEndCol, sourceSpanEndLine, sourceSpanEndOffset, sourceSpanStartCol, sourceSpanStartLine, sourceSpanStartOffset)
+import Aihc.Parser.Types (FoundToken (..), ParseErrorBundle, ParserErrorComponent (..), TokStream (..), sourcePosSpan)
import Data.List qualified as List
import Data.List.NonEmpty qualified as NE
import Data.Maybe (fromMaybe)
@@ -19,17 +19,51 @@
import Text.Megaparsec.Error (ErrorFancy (..), ErrorItem (..))
import Text.Megaparsec.Error qualified as MPE
-parseErrorBundleToSpannedText :: ParseErrorBundle -> [(SourceSpan, Text)]
-parseErrorBundleToSpannedText bundle =
- parseErrorsToSpannedText (NE.toList (MPE.bundleErrors bundle))
+-- | Render the errors of a failed parse, each with a source span.
+--
+-- The stream is a fresh stream over the same input, positioned at offset 0.
+-- It must not be the stream that was parsed: holding that one keeps its
+-- memoized successor chain alive for the whole parse (see
+-- 'Aihc.Parser.Types.runTokStreamParser').
+parseErrorBundleToSpannedText :: FilePath -> TokStream -> ParseErrorBundle -> [(SourceSpan, Text)]
+parseErrorBundleToSpannedText sourceName stream bundle =
+ parseErrorsToSpannedText sourceName stream (NE.toList (MPE.bundleErrors bundle))
-parseErrorsToSpannedText :: [MPE.ParseError TokStream ParserErrorComponent] -> [(SourceSpan, Text)]
-parseErrorsToSpannedText errs =
- [ (fromMaybe NoSourceSpan mSpan, RText.renderStrict (layoutPretty defaultLayoutOptions doc))
+-- | Render parse errors, each with a source span. See
+-- 'parseErrorBundleToSpannedText' for the stream argument.
+parseErrorsToSpannedText :: FilePath -> TokStream -> [MPE.ParseError TokStream ParserErrorComponent] -> [(SourceSpan, Text)]
+parseErrorsToSpannedText sourceName stream errs =
+ [ (fromMaybe (spanAtOffset sourceName stream (MP.errorOffset err)) mSpan, RText.renderStrict (layoutPretty defaultLayoutOptions doc))
| err <- List.sortOn MP.errorOffset errs,
(mSpan, doc) <- renderParseErrors err
]
+-- | The span of the token at an offset of a stream that starts at offset 0.
+-- This is where the parser stood when it raised an error at that offset, so
+-- it locates errors that carry no token of their own, such as one raised with
+-- 'fail'. Past the last token the span is the zero-width end of that token; a
+-- stream with no tokens at all gives the zero-width start of the input.
+spanAtOffset :: FilePath -> TokStream -> Int -> SourceSpan
+spanAtOffset sourceName = go
+ where
+ go stream n =
+ case tokStreamNext stream of
+ Just (tok, rest)
+ | n > 0 -> go rest (n - 1)
+ | otherwise -> lexTokenSpan tok
+ Nothing ->
+ case tokStreamPrevToken stream of
+ Just prev -> spanEnd (lexTokenSpan prev)
+ Nothing -> sourcePosSpan (MP.initialPos sourceName)
+ spanEnd sp =
+ sp
+ { sourceSpanStartLine = sourceSpanEndLine sp,
+ sourceSpanStartCol = sourceSpanEndCol sp,
+ sourceSpanStartOffset = sourceSpanEndOffset sp
+ }
+
+-- | Render an error's messages, each with the span of the token it names, if
+-- it names one.
renderParseErrors :: MPE.ParseError TokStream ParserErrorComponent -> [(Maybe SourceSpan, Doc ann)]
renderParseErrors err =
case err of
diff --git a/src/Aihc/Parser/Internal/Expr.hs b/src/Aihc/Parser/Internal/Expr.hs
--- a/src/Aihc/Parser/Internal/Expr.hs
+++ b/src/Aihc/Parser/Internal/Expr.hs
@@ -21,9 +21,10 @@
import Aihc.Parser.Internal.Type (typeAtomParser, typeParser, typeSignatureParser)
import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText)
import Aihc.Parser.Syntax
-import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken)
+import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)
import Control.Monad (guard)
import Data.Functor (($>))
+import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Text.Megaparsec (anySingle, lookAhead, (<|>))
import Text.Megaparsec qualified as MP
@@ -49,15 +50,19 @@
exprOrPattern = do
expr <- exprP
-- An expression can stop before a pattern-only argument or suffix.
- MP.notFollowedBy $
- expectedTok TkReservedAt
- <|> expectedTok TkPrefixBang
- <|> expectedTok TkPrefixTilde
- <|> expectedTok TkReservedDoubleColon
- mArrow <- MP.optional (expectedTok TkReservedLeftArrow)
- case mArrow of
- Just () -> Left <$> liftCheck (checkPattern expr)
- Nothing -> pure (Right expr)
+ -- The four tokens that mean it did are recognized on the peeked token
+ -- rather than by four alternatives under 'MP.notFollowedBy'.
+ mKind <- peekTokenKind
+ case mKind of
+ Just TkReservedAt -> MP.empty
+ Just TkPrefixBang -> MP.empty
+ Just TkPrefixTilde -> MP.empty
+ Just TkReservedDoubleColon -> MP.empty
+ _ -> pure ()
+ hasArrow <- optionalTok TkReservedLeftArrow
+ if hasArrow
+ then Left <$> liftCheck (checkPattern expr)
+ else pure (Right expr)
patternBind = do
pat <- patternParser
@@ -126,10 +131,10 @@
-- no @->@ follows.
maybeViewPattern :: Expr -> TokParser Expr
maybeViewPattern lhs = do
- mArrow <- MP.optional (expectedTok TkReservedRightArrow)
- case mArrow of
- Just () -> EViewPat lhs <$> texprParser
- Nothing -> pure lhs
+ hasArrow <- optionalTok TkReservedRightArrow
+ if hasArrow
+ then EViewPat lhs <$> texprParser
+ else pure lhs
-- | Like 'exprParser' but also allows the view-pattern arrow @->@ at the
-- top level. This corresponds to GHC\'s @texp@ production, which is used
@@ -211,7 +216,7 @@
doStmtParser :: TokParser (DoStmt Expr)
doStmtParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordLet -> MP.try doLetStmtParser <|> doBindOrExprStmtParser
TkKeywordRec -> doRecStmtParser
@@ -247,16 +252,26 @@
-- | Shared infix-chain parser used by the report core and contextual
-- expression variants such as TransformListComp.
+--
+-- The operator is looked for on the peeked token first. Every expression in
+-- the file ends by failing to find one more operator, and letting
+-- 'infixOperatorParser' fail made that failure cost a parse error and its
+-- hints.
exprInfixChainParser :: TokParser Expr -> TokParser Expr
exprInfixChainParser lexp = do
lhs <- lexp
- rest <-
- MP.many
- ( (,)
- <$> infixOperatorParser
- <*> region "after infix operator" lexp
- )
+ rest <- MP.many infixOperatorAndOperand
pure (foldInfixL buildInfix lhs rest)
+ where
+ infixOperatorAndOperand = do
+ mKind <- peekTokenKind
+ case mKind of
+ Just kind
+ | startsInfixOperator kind ->
+ (,)
+ <$> infixOperatorParser
+ <*> region "after infix operator" lexp
+ _ -> MP.empty
-- | Report core:
--
@@ -278,11 +293,24 @@
Just sccPragma -> EPragma sccPragma <$> lexpParserWith atomContext
Nothing -> lexpBaseParserWith atomContext (appExprParserWith (atomOrRecordExprParserWith atomContext))
+-- | Every block form starts with a distinct keyword and prefix negation with a
+-- minus token, so the next token decides which alternative can possibly match.
+-- Dispatching on it rather than running the alternatives in turn matters: this
+-- parser runs at every expression position, and the chain used to attempt —
+-- and allocate continuations for — nine block parsers plus a backtracking
+-- negation before reaching the application parser that almost always wins.
lexpBaseParserWith :: AtomContext -> TokParser Expr -> TokParser Expr
-lexpBaseParserWith atomContext appParser =
- lexpBlockParserWith atomContext
- <|> MP.try negateExprParser
- <|> appParser
+lexpBaseParserWith atomContext appParser = do
+ tok <- peekToken
+ case lexTokenKind tok of
+ kind
+ | Just blockParser <- lexpBlockParserForToken atomContext kind -> blockParser
+ TkVarSym "-" -> negateOrApp
+ TkMinusOperator -> negateOrApp
+ TkPrefixMinus -> negateOrApp
+ _ -> appParser
+ where
+ negateOrApp = MP.try negateExprParser <|> appParser
-- | The Haskell report's @lexp@ production: lambda, let, if, case, do, and
-- function application. GHC extensions add more forms at the same grammar
@@ -305,21 +333,26 @@
lexpBlockParser = lexpBlockParserWith NormalExprAtom
lexpBlockParserWith :: AtomContext -> TokParser Expr
-lexpBlockParserWith atomContext =
- doExprParser
- <|> mdoExprParser
- <|> qualifiedDoExprParser
- <|> qualifiedMdoExprParser
- <|> ifExprParser
- <|> caseExprParser
- <|> letExprParser
- <|> procBlockParser
- <|> lambdaExprParser
- where
- procBlockParser
- | atomContext == NormalExprAtom = procExprParser
- | otherwise = MP.empty
+lexpBlockParserWith atomContext = do
+ tok <- peekToken
+ fromMaybe MP.empty (lexpBlockParserForToken atomContext (lexTokenKind tok))
+-- | The block parser a token can start, if any. Each block form begins with
+-- its own keyword, so at most one alternative is ever viable.
+lexpBlockParserForToken :: AtomContext -> LexTokenKind -> Maybe (TokParser Expr)
+lexpBlockParserForToken atomContext kind =
+ case kind of
+ TkKeywordDo -> Just doExprParser
+ TkKeywordMdo -> Just mdoExprParser
+ TkQualifiedDo {} -> Just qualifiedDoExprParser
+ TkQualifiedMdo {} -> Just qualifiedMdoExprParser
+ TkKeywordIf -> Just ifExprParser
+ TkKeywordCase -> Just caseExprParser
+ TkKeywordLet -> Just letExprParser
+ TkKeywordProc | atomContext == NormalExprAtom -> Just procExprParser
+ TkReservedBackslash -> Just lambdaExprParser
+ _ -> Nothing
+
getSCCPragma :: Pragma -> Maybe Pragma
getSCCPragma p = case pragmaType p of
PragmaSCC _ -> Just p
@@ -381,29 +414,34 @@
-- variants. The caller chooses the @aexp@-like atom parser.
appExprParserWith :: TokParser Expr -> TokParser Expr
appExprParserWith atomParser = do
- startInput <- MP.getInput
+ startState <- MP.getParserState
+ let !startInput = MP.stateInput startState
+ !startOffset = MP.stateOffset startState
+ !inputStart = MP.pstateSourcePos (MP.statePosState startState)
first <- atomParser
rest <- MP.many appArg
case rest of
[] -> pure first
_ -> do
- endInput <- MP.getInput
- let startSpan = inputStartSpan startInput
- endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)
- appSpan = mergeSourceSpans startSpan endSpan
+ endState <- MP.getParserState
+ let !endInput = MP.stateInput endState
+ !endOffset = MP.stateOffset endState
+ appSpan = consumedSpan inputStart startInput startOffset endInput endOffset
pure (EAnn (mkAnnotation appSpan) (foldl applyArg first rest))
where
appArg :: TokParser (Either Type Expr)
appArg = (Left <$> typeAppArg) <|> (Right <$> appExprArgParser)
typeAppArg :: TokParser Type
- typeAppArg = MP.try $ do
- expectedTok TkTypeApp
- typeAtomParser
+ typeAppArg = do
+ hasAt <- nextTokenIs TkTypeApp
+ if hasAt
+ then MP.try (expectedTok TkTypeApp *> typeAtomParser)
+ else MP.empty
appExprArgParser :: TokParser Expr
appExprArgParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
-- GHC rejects bare explicit namespace syntax as a function argument:
-- @f type T@ is invalid, while @f (type T)@ is accepted syntactically.
@@ -429,20 +467,35 @@
atomOrRecordExprParser :: TokParser Expr
atomOrRecordExprParser = atomOrRecordExprParserWith NormalExprAtom
+-- | The record-base atom parser accepts exactly the @aexp@ forms, so for any
+-- other leading token it fails without consuming input and the atom parser
+-- has to be run instead. Which of the two applies is decided by the next
+-- token, rather than by trying the record path and letting it fail: this
+-- parser runs at every atom position, and the failing alternative allocated a
+-- continuation and an error for each one.
atomOrRecordExprParserWith :: AtomContext -> TokParser Expr
-atomOrRecordExprParserWith atomContext =
- recordExprParser <|> atomExprParserWith atomContext
+atomOrRecordExprParserWith atomContext = do
+ tok <- peekToken
+ if startsAtomOnlyForm atomContext (lexTokenKind tok)
+ then atomExprParserWith atomContext
+ else recordExprParser
where
recordExprParser :: TokParser Expr
recordExprParser = do
base <- recordBaseAtomExprParserWith atomContext
applyRecordSuffixes base
+ -- Record braces and record dots are suffixes on an atom that almost
+ -- never follow it, so both are decided on the peeked token. Running
+ -- 'recordBracesParser' under 'MP.optional' meant every atom in the file
+ -- paid for a failed brace parse.
applyRecordSuffixes :: Expr -> TokParser Expr
applyRecordSuffixes e = do
- mRecordFields <- MP.optional recordBracesParser
- case mRecordFields of
- Just (fields, hasWildcard) -> do
+ hasBrace <- nextTokenIs TkSpecialLBrace
+ if not hasBrace
+ then applyRecordDotSuffixes e
+ else do
+ (fields, hasWildcard) <- recordBracesParser
let result = case peelExprAnn e of
EVar name
| isConLikeName name ->
@@ -450,18 +503,18 @@
_ ->
ERecordUpd e (map normalizeField fields)
applyRecordSuffixes result
- Nothing -> applyRecordDotSuffixes e
applyRecordDotSuffixes :: Expr -> TokParser Expr
applyRecordDotSuffixes e = do
- recordDotEnabled <- isExtensionEnabled OverloadedRecordDot
- if not recordDotEnabled || not (recordDotMayFollow e)
+ hasDot <- nextTokenIs TkRecordDot
+ if not hasDot || not (recordDotMayFollow e)
then pure e
else do
- mDot <- MP.optional (expectedTok TkRecordDot)
- case mDot of
- Nothing -> pure e
- Just () -> do
+ recordDotEnabled <- isExtensionEnabled OverloadedRecordDot
+ if not recordDotEnabled
+ then pure e
+ else do
+ expectedTok TkRecordDot
fieldName <- recordFieldNameParser
applyRecordSuffixes (EGetField e fieldName)
@@ -489,7 +542,7 @@
recordFieldBindingParser :: TokParser (Name, Maybe Expr, SourceSpan)
recordFieldBindingParser = withSpan $ do
fieldName <- recordFieldNameParser
- mAssign <- MP.optional (expectedTok TkReservedEquals *> exprParser)
+ mAssign <- optionalTokThen TkReservedEquals exprParser
pure (fieldName,mAssign,)
-- | Parse the expression forms that correspond to the report's @aexp@
@@ -509,7 +562,7 @@
-- > | aexp '{' fbind_1 ',' ... ',' fbind_n '}'
recordBaseAtomExprParserWith :: AtomContext -> TokParser Expr
recordBaseAtomExprParserWith atomContext = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkImplicitParam {} -> implicitParamExprParser
_ -> simpleAtomExprParserWith atomContext
@@ -520,12 +573,29 @@
--
-- This variant also admits extension-only atoms such as block arguments and
-- explicit namespace syntax when the corresponding extensions are enabled.
+-- | Whether a token starts an expression form that is not an @aexp@, and so
+-- can never be a record construction or update base.
+startsAtomOnlyForm :: AtomContext -> LexTokenKind -> Bool
+startsAtomOnlyForm atomContext kind =
+ case kind of
+ TkKeywordType -> True
+ TkReservedBackslash -> True
+ TkKeywordLet -> True
+ TkKeywordDo -> True
+ TkKeywordMdo -> True
+ TkQualifiedDo {} -> True
+ TkQualifiedMdo {} -> True
+ TkKeywordCase -> True
+ TkKeywordIf -> True
+ TkKeywordProc -> atomContext == NormalExprAtom
+ _ -> False
+
atomExprParser :: TokParser Expr
atomExprParser = atomExprParserWith NormalExprAtom
atomExprParserWith :: AtomContext -> TokParser Expr
atomExprParserWith atomContext = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkImplicitParam {} -> implicitParamExprParser
TkKeywordType -> do
@@ -554,10 +624,19 @@
simpleAtomExprParserWith :: AtomContext -> TokParser Expr
simpleAtomExprParserWith atomContext = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkPrefixMinus -> prefixNegateAtomExprParserWith atomContext
- TkSpecialLParen -> MP.try parenOperatorExprParser <|> parenExprParser
+ -- @(+)@ and @(x + y)@ both start with @(@, and only the second token
+ -- tells them apart. Without that check every parenthesized expression
+ -- paid for a failed 'parenOperatorExprParser' parse first.
+ TkSpecialLParen -> do
+ mAfterParen <- lookAhead (MP.optional (anySingle *> anySingle))
+ case lexTokenKind <$> mAfterParen of
+ Just afterParen
+ | startsParenOperator afterParen ->
+ MP.try parenOperatorExprParser <|> parenExprParser
+ _ -> parenExprParser
TkSpecialUnboxedLParen -> parenExprParser
TkSpecialLBracket -> listExprParser
TkInteger {} -> intExprParser
@@ -627,6 +706,20 @@
TkPrefixMinus -> Just ()
_ -> Nothing
+-- | Whether a token can be the operator of a parenthesized operator
+-- expression such as @(+)@; see 'operatorExprNameParser'.
+startsParenOperator :: LexTokenKind -> Bool
+startsParenOperator kind =
+ case kind of
+ TkVarSym {} -> True
+ TkConSym {} -> True
+ TkQVarSym {} -> True
+ TkQConSym {} -> True
+ TkMinusOperator -> True
+ TkReservedColon -> True
+ TkReservedAt -> True
+ _ -> False
+
parenOperatorExprParser :: TokParser Expr
parenOperatorExprParser =
withSpanAnn (EAnn . mkAnnotation) $
@@ -683,7 +776,7 @@
rhsParserWithBodyParser :: RhsArrowKind -> TokParser body -> TokParser (Rhs body)
rhsParserWithBodyParser arrowKind bodyParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkReservedPipe -> guardedRhssParserWithBodyParser arrowKind bodyParser
TkReservedRightArrow | RhsArrowCase <- arrowKind -> unguardedRhsParserWithBodyParser arrowKind bodyParser
@@ -734,7 +827,7 @@
-- > | infixexp
guardQualifierParser :: RhsArrowKind -> TokParser GuardQualifier
guardQualifierParser arrowKind = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordLet -> MP.try guardLetParser <|> guardBindOrExprParser arrowKind
_ -> guardBindOrExprParser arrowKind
@@ -795,10 +888,10 @@
parenExprParser :: TokParser Expr
parenExprParser = withSpanAnn (EAnn . mkAnnotation) $ do
(tupleFlavor, closeTok) <- tupleDelimsParser
- mClosed <- MP.optional (expectedTok closeTok)
- case mClosed of
- Just () -> pure (ETuple tupleFlavor [])
- Nothing ->
+ closedImmediately <- optionalTok closeTok
+ if closedImmediately
+ then pure (ETuple tupleFlavor [])
+ else
if tupleFlavor == Boxed
then MP.try (parseNegateParen closeTok) <|> parseBoxedContent closeTok
else MP.try (parseUnboxedSumExprLeadingBars closeTok) <|> parseTupleOrParen tupleFlavor closeTok
@@ -823,7 +916,7 @@
)
)
let withInfix = foldInfixL buildInfix negBase rest
- mTypeSig <- MP.optional (expectedTok TkReservedDoubleColon *> typeSignatureParser)
+ mTypeSig <- optionalTokThen TkReservedDoubleColon typeSignatureParser
let typed = case mTypeSig of
Just ty -> ETypeSig withInfix ty
Nothing -> withInfix
@@ -862,7 +955,7 @@
Just op ->
pure (EParen (ESectionL base op))
Nothing -> do
- mTypeSig <- MP.optional (expectedTok TkReservedDoubleColon *> typeSignatureParser)
+ mTypeSig <- optionalTokThen TkReservedDoubleColon typeSignatureParser
let typed = case mTypeSig of
Just ty -> ETypeSig base ty
Nothing -> base
@@ -870,11 +963,10 @@
finalExpr <- maybeViewPattern typed
finishBoxed closeTok (Just finalExpr)
Just op -> do
- mClose <- MP.optional (expectedTok closeTok)
- case mClose of
- Just () ->
- pure (EParen (ESectionL base op))
- Nothing -> do
+ closedAfterOperator <- optionalTok closeTok
+ if closedAfterOperator
+ then pure (EParen (ESectionL base op))
+ else do
rhs <- region "after infix operator" lexpParser
more <-
MP.many
@@ -891,7 +983,7 @@
expectedTok closeTok
pure (EParen (ESectionL fullInfix trailOp))
Nothing -> do
- mTypeSig <- MP.optional (expectedTok TkReservedDoubleColon *> typeSignatureParser)
+ mTypeSig <- optionalTokThen TkReservedDoubleColon typeSignatureParser
let typed = case mTypeSig of
Just ty -> ETypeSig fullInfix ty
Nothing -> fullInfix
@@ -924,49 +1016,49 @@
_ -> Nothing
finishBoxed closeTok mFirst = do
- mComma <- MP.optional (expectedTok TkSpecialComma)
- case (mFirst, mComma) of
- (Just e, Nothing) -> do
+ hasComma <- optionalTok TkSpecialComma
+ case (mFirst, hasComma) of
+ (Just e, False) -> do
expectedTok closeTok
pure (EParen e)
- (_, Just ()) -> do
+ (_, True) -> do
rest <- parseTupleElems closeTok
pure (ETuple Boxed (mFirst : rest))
- (Nothing, Nothing) ->
+ (Nothing, False) ->
fail "expected expression or closing paren"
parseTupleOrParen tupleFlavor closeTok = do
first <- MP.optional texprParser
- mComma <- MP.optional (expectedTok TkSpecialComma)
- case (first, mComma) of
- (Just e, Nothing) ->
+ hasComma <- optionalTok TkSpecialComma
+ case (first, hasComma) of
+ (Just e, False) ->
case tupleFlavor of
Boxed -> do
expectedTok closeTok
pure (EParen e)
Unboxed -> do
- mPipe <- MP.optional (expectedTok TkReservedPipe)
- case mPipe of
- Just () -> do
+ hasPipe <- optionalTok TkReservedPipe
+ if hasPipe
+ then do
trailingBars <- MP.many (expectedTok TkReservedPipe)
expectedTok closeTok
let arity = 2 + length trailingBars
pure (EUnboxedSum 0 arity e)
- Nothing -> do
+ else do
expectedTok closeTok
pure (ETuple Unboxed [Just e])
- (_, Just ()) -> do
+ (_, True) -> do
rest <- parseTupleElems closeTok
pure (ETuple tupleFlavor (first : rest))
- (Nothing, Nothing) ->
+ (Nothing, False) ->
fail "expected expression or closing paren"
parseTupleElems closeTok = do
e <- MP.optional texprParser
- mComma <- MP.optional (expectedTok TkSpecialComma)
- case mComma of
- Just () -> (e :) <$> parseTupleElems closeTok
- Nothing -> do
+ hasComma <- optionalTok TkSpecialComma
+ if hasComma
+ then (e :) <$> parseTupleElems closeTok
+ else do
expectedTok closeTok
pure [e]
@@ -983,10 +1075,10 @@
listExprParser :: TokParser Expr
listExprParser = withSpanAnn (EAnn . mkAnnotation) $ do
expectedTok TkSpecialLBracket
- mClose <- MP.optional (expectedTok TkSpecialRBracket)
- case mClose of
- Just () -> pure (EList [])
- Nothing -> do
+ closedImmediately <- optionalTok TkSpecialRBracket
+ if closedImmediately
+ then pure (EList [])
+ else do
first <- exprParser
parseListTail first
@@ -1039,7 +1131,7 @@
compStmtParser :: TokParser CompStmt
compStmtParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordLet -> MP.try compLetStmtParser <|> compGenOrGuardParser
TkKeywordThen -> compTransformStmtParser <|> compGenOrGuardParser
@@ -1054,7 +1146,7 @@
guard enabled
expectedTok TkKeywordThen
-- Check for 'group' forms first
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkVarId "group" -> compGroupStmtParser
_ -> compThenStmtParser
@@ -1063,7 +1155,7 @@
compGroupStmtParser :: TokParser CompStmt
compGroupStmtParser = do
varIdTok "group"
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordBy -> do
expectedTok TkKeywordBy
@@ -1081,10 +1173,10 @@
compThenStmtParser :: TokParser CompStmt
compThenStmtParser = do
f <- compTransformExprParser
- mBy <- MP.optional (expectedTok TkKeywordBy)
- case mBy of
- Just () -> CompThenBy f <$> exprParser
- Nothing -> pure (CompThen f)
+ hasBy <- optionalTok TkKeywordBy
+ if hasBy
+ then CompThenBy f <$> exprParser
+ else pure (CompThen f)
-- | Expression parser for TransformListComp context.
-- Parses an expression but treats bare 'by' and 'using' as terminators
@@ -1171,7 +1263,7 @@
-- These are treated as contextual keywords in TransformListComp context.
compTransformAtomOrRecordExprParser :: TokParser Expr
compTransformAtomOrRecordExprParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordBy -> MP.empty
TkKeywordUsing -> MP.empty
@@ -1277,7 +1369,7 @@
localMultiplicityTagParser :: TokParser MultiplicityTag
localMultiplicityTagParser = do
expectedTok TkPrefixPercent
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkInteger 1 _ -> anySingle $> LinearMultiplicityTag
_ -> ExplicitMultiplicityTag <$> typeAtomParser
@@ -1355,7 +1447,7 @@
compactSpliceBodyParser :: TokParser Expr
compactSpliceBodyParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkReservedBackslash -> MP.empty
TkKeywordLet -> MP.empty
diff --git a/src/Aihc/Parser/Internal/FromTokens.hs b/src/Aihc/Parser/Internal/FromTokens.hs
--- a/src/Aihc/Parser/Internal/FromTokens.hs
+++ b/src/Aihc/Parser/Internal/FromTokens.hs
@@ -37,7 +37,7 @@
runParserFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a
runParserFromTokens parser sourceName toks =
case runTokStreamParser parser sourceName (mkTokStreamFromTokens toks) of
- Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)
+ Left bundle -> ParseErr (parseErrorBundleToSpannedText sourceName (rebuildStream mkTokStreamFromTokens toks) bundle)
Right parsed -> ParseOk parsed
parseFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a
diff --git a/src/Aihc/Parser/Internal/Import.hs b/src/Aihc/Parser/Internal/Import.hs
--- a/src/Aihc/Parser/Internal/Import.hs
+++ b/src/Aihc/Parser/Internal/Import.hs
@@ -98,9 +98,9 @@
parseDotDotFirst = do
expectedTok TkReservedDotDot
- MP.optional (expectedTok TkSpecialComma) >>= \case
- Nothing -> pure MembersAll
- Just _ -> do
+ optionalTok TkSpecialComma >>= \case
+ False -> pure MembersAll
+ True -> do
trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma
pure (MembersListAll 0 trailingMembers)
@@ -109,18 +109,18 @@
parseMemberSegments [firstMember]
parseMemberSegments members =
- MP.optional (expectedTok TkSpecialComma) >>= \case
- Nothing -> pure (MembersList members)
- Just _ ->
+ optionalTok TkSpecialComma >>= \case
+ False -> pure (MembersList members)
+ True ->
(expectedTok TkReservedDotDot >> parseWildcardTail members)
<|> do
nextMember <- memberNameParser
parseMemberSegments (members <> [nextMember])
parseWildcardTail members =
- MP.optional (expectedTok TkSpecialComma) >>= \case
- Nothing -> pure (MembersListAll (length members) members)
- Just _ -> do
+ optionalTok TkSpecialComma >>= \case
+ False -> pure (MembersListAll (length members) members)
+ True -> do
trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma
pure (MembersListAll (length members) (members <> trailingMembers))
@@ -163,7 +163,7 @@
unexpectedExpecting = "import declaration without duplicate 'qualified'",
unexpectedContext = []
}
- importAlias <- MP.optional (expectedTok TkVarAs *> moduleNameParser)
+ importAlias <- optionalTokThen TkVarAs moduleNameParser
importSpec <- MP.optional importSpecParser
let isQualified = preQualified || isJust postQualified
pure $ \span' ->
diff --git a/src/Aihc/Parser/Internal/Module.hs b/src/Aihc/Parser/Internal/Module.hs
--- a/src/Aihc/Parser/Internal/Module.hs
+++ b/src/Aihc/Parser/Internal/Module.hs
@@ -13,17 +13,17 @@
import Aihc.Parser.Internal.Common
( TokParser,
closeAndExpectRBrace,
+ consumedSpan,
eofTok,
expectedTok,
- inputStartSpan,
lazy,
+ optionalTok,
skipSemicolons,
)
import Aihc.Parser.Internal.Decl (declParser)
import Aihc.Parser.Internal.Import (importDeclParser, languagePragmaParser, moduleHeaderParser)
-import Aihc.Parser.Lex (LexToken (lexTokenSpan), LexTokenKind (..), lexTokenKind)
-import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mergeSourceSpans, mkAnnotation, noSourceSpan)
-import Aihc.Parser.Types (TokStream (tokStreamPrevToken))
+import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind)
+import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mkAnnotation)
import Control.Monad (void)
import Text.Megaparsec qualified as MP
@@ -36,7 +36,10 @@
-- the whole-module span suspended until the corresponding result is demanded.
moduleParser :: TokParser Module
moduleParser = do
- startInput <- MP.getInput
+ startState <- MP.getParserState
+ let !startInput = MP.stateInput startState
+ !startOffset = MP.stateOffset startState
+ !inputStart = MP.pstateSourcePos (MP.statePosState startState)
languagePragmas <- MP.many (languagePragmaParser <* MP.many (expectedTok TkSpecialSemicolon))
mHeader <- MP.optional (moduleHeaderParser <* MP.many (expectedTok TkSpecialSemicolon))
expectedTok TkSpecialLBrace
@@ -49,8 +52,7 @@
<* MP.lookAhead eofTok
)
MP.updateParserState (\state -> state {MP.stateParseErrors = MP.stateParseErrors finalState})
- let endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken (MP.stateInput finalState))
- moduleSpan = mergeSourceSpans (inputStartSpan startInput) endSpan
+ let moduleSpan = consumedSpan inputStart startInput startOffset (MP.stateInput finalState) (MP.stateOffset finalState)
pure
Module
{ moduleAnns = [mkAnnotation moduleSpan],
@@ -99,4 +101,4 @@
let kind = lexTokenKind tok
in kind /= TkSpecialSemicolon && kind /= TkSpecialRBrace
)
- void (MP.optional (expectedTok TkSpecialSemicolon))
+ void (optionalTok TkSpecialSemicolon)
diff --git a/src/Aihc/Parser/Internal/Pattern.hs b/src/Aihc/Parser/Internal/Pattern.hs
--- a/src/Aihc/Parser/Internal/Pattern.hs
+++ b/src/Aihc/Parser/Internal/Pattern.hs
@@ -102,14 +102,8 @@
buildPatternApp :: Pattern -> Pattern -> Pattern
buildPatternApp lhs rhs =
case peelPatternAnn lhs of
- PCon name typeArgs args ->
- PAnn
- (mkAnnotation NoSourceSpan)
- (PCon name typeArgs (args <> [rhs]))
- PBuiltinCon con typeArgs args ->
- PAnn
- (mkAnnotation NoSourceSpan)
- (PBuiltinCon con typeArgs (args <> [rhs]))
+ PCon name typeArgs args -> PCon name typeArgs (args <> [rhs])
+ PBuiltinCon con typeArgs args -> PBuiltinCon con typeArgs (args <> [rhs])
_ -> lhs
-- | Parse an atomic pattern (@apat@ in the Haskell Report).
@@ -132,7 +126,7 @@
nonAsApatParser :: TokParser Pattern
nonAsApatParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkTypeApp -> do
typeAbstractionsEnabled <- isExtensionEnabled TypeAbstractions
@@ -273,7 +267,7 @@
thSplicePatternParser :: TokParser Pattern
thSplicePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do
expectedTok TkTHSplice
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkKeywordType -> MP.empty
_ -> PSplice <$> atomExprParser
@@ -297,15 +291,15 @@
varOrConPatternParser :: TokParser Pattern
varOrConPatternParser = do
(tok, name) <- identifierNameWithTokenParser
- mNextTok <- MP.optional (lookAhead anySingle)
+ mNextTok <- peekTokenMaybe
let ann = mkAnnotation (lexTokenSpan tok)
case mNextTok of
Just nextTok
| isConLikeName name && lexTokenKind nextTok == TkSpecialLBrace -> do
(fields, hasWildcard) <- braces recordPatternFieldListParser
endInput <- MP.getInput
- let endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)
- recordSpan = mergeSourceSpans (lexTokenSpan tok) endSpan
+ let startSpan = lexTokenSpan tok
+ recordSpan = maybe startSpan (mergeSourceSpans startSpan . lexTokenSpan) (tokStreamPrevToken endInput)
pure (PAnn (mkAnnotation recordSpan) (PRecord name fields hasWildcard))
_ ->
pure $
@@ -317,12 +311,12 @@
recordFieldPatternParser :: TokParser (RecordField Pattern)
recordFieldPatternParser = do
field <- recordFieldNameParser
- mEq <- MP.optional (expectedTok TkReservedEquals)
- case mEq of
- Just () -> do
+ hasEquals <- optionalTok TkReservedEquals
+ if hasEquals
+ then do
pat <- subpatternWithBareViewParser
pure (RecordField field pat False)
- Nothing -> do
+ else
-- NamedFieldPuns: just "field" means "field = field"
pure (RecordField field (PVar (nameToUnqualified field)) True)
@@ -358,7 +352,7 @@
subpatternWithBareViewParser = do
mResult <- MP.optional . MP.try $ do
expr <- exprParser
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkReservedRightArrow -> pure (Left expr)
TkSpecialComma -> Right <$> liftCheck (checkPattern expr)
@@ -378,7 +372,7 @@
parenOrTuplePatternParser :: TokParser Pattern
parenOrTuplePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do
(tupleFlavor, closeTok) <- tupleDelimsParser
- mNextTok <- MP.optional (lookAhead anySingle)
+ mNextTok <- peekTokenMaybe
case fmap lexTokenKind mNextTok of
Just nextKind
| nextKind == closeTok -> unitPatternParser tupleFlavor closeTok
@@ -465,7 +459,7 @@
-- the surrounding parens serve as prefix notation rather than grouping.
parenPatElementParser :: TokParser (Bool, Pattern)
parenPatElementParser = do
- tok <- lookAhead anySingle
+ tok <- peekToken
case lexTokenKind tok of
TkPrefixBang -> (False,) <$> patternParser
TkPrefixTilde -> (False,) <$> patternParser
@@ -490,7 +484,7 @@
-- Look ahead to check what comes after the operator
mNext <- MP.optional . lookAhead . MP.try $ do
_ <- anySingle -- skip the operator token itself
- lookAhead anySingle
+ peekToken
case fmap lexTokenKind mNext of
-- If followed by closing delimiters, parse as operator pattern
Just TkSpecialRParen -> (True,) <$> operatorPatternParser
@@ -521,28 +515,28 @@
tupleOrParenPatternParser tupleFlavor closeTok = do
(isBareOp, first) <- parenPatElementParser
- mComma <- MP.optional (expectedTok TkSpecialComma)
- case mComma of
- Nothing -> do
+ hasComma <- optionalTok TkSpecialComma
+ if hasComma
+ then do
+ (_, second) <- parenPatElementParser
+ more <- MP.many (expectedTok TkSpecialComma *> (snd <$> parenPatElementParser))
+ expectedTok closeTok
+ pure (PTuple tupleFlavor (first : second : more))
+ else do
-- Check for pipe (unboxed sum: pattern in first slot)
- mPipe <- if tupleFlavor == Unboxed then MP.optional (expectedTok TkReservedPipe) else pure Nothing
- case mPipe of
- Just () -> do
+ hasPipe <- if tupleFlavor == Unboxed then optionalTok TkReservedPipe else pure False
+ if hasPipe
+ then do
-- (# pat | ... #) - pattern in first slot of sum
trailingBars <- MP.many (expectedTok TkReservedPipe)
expectedTok closeTok
let arity = 2 + length trailingBars
pure (PUnboxedSum 0 arity first)
- Nothing -> do
+ else do
expectedTok closeTok
if tupleFlavor == Boxed
then parenOrSymConParser isBareOp first
else pure (PTuple Unboxed [first])
- Just () -> do
- (_, second) <- parenPatElementParser
- more <- MP.many (expectedTok TkSpecialComma *> (snd <$> parenPatElementParser))
- expectedTok closeTok
- pure (PTuple tupleFlavor (first : second : more))
parseUnboxedSumPatLeadingBars closeTok = do
-- Parse (# | | ... | pat | ... | #) where pattern is not in first slot
diff --git a/src/Aihc/Parser/Internal/Type.hs b/src/Aihc/Parser/Internal/Type.hs
--- a/src/Aihc/Parser/Internal/Type.hs
+++ b/src/Aihc/Parser/Internal/Type.hs
@@ -129,7 +129,7 @@
( do
expectedTok TkSpecialLBrace
ident <- tyVarNameParser
- mKind <- MP.optional (expectedTok TkReservedDoubleColon *> typeParser)
+ mKind <- optionalTokThen TkReservedDoubleColon typeParser
expectedTok TkSpecialRBrace
pure (\span' -> TyVarBinder [mkAnnotation span'] ident mKind TyVarBInferred TyVarBVisible)
)
@@ -395,10 +395,9 @@
TkConId {} -> typeIdentifierParser
TkQVarId {} -> typeIdentifierParser
TkQConId {} -> typeIdentifierParser
- _ -> do
- thAny <- thAnyEnabled
- ipEnabled <- isExtensionEnabled ImplicitParams
- typeAtomParserAlternatives thAny ipEnabled
+ -- Every other alternative in 'typeAtomParserAlternatives' begins with a
+ -- token kind already dispatched above, so only these three can match.
+ _ -> MP.try promotedTypeParser <|> typeStarParser <|> typeIdentifierParser
typeAtomParserAlternatives :: Bool -> Bool -> TokParser Type
typeAtomParserAlternatives thAny ipEnabled =
@@ -510,10 +509,10 @@
typeListParser :: TokParser Type
typeListParser = withSpanAnn (TAnn . mkAnnotation) $ do
expectedTok TkSpecialLBracket
- mClosed <- MP.optional (expectedTok TkSpecialRBracket)
- case mClosed of
- Just () -> pure (TBuiltinCon BuiltinList Unpromoted)
- Nothing -> do
+ closedImmediately <- optionalTok TkSpecialRBracket
+ if closedImmediately
+ then pure (TBuiltinCon BuiltinList Unpromoted)
+ else do
elems <- typeParser `MP.sepBy1` expectedTok TkSpecialComma
expectedTok TkSpecialRBracket
pure (TList Unpromoted elems)
@@ -521,11 +520,10 @@
typeParenOrTupleParser :: TokParser Type
typeParenOrTupleParser = withSpanAnn (TAnn . mkAnnotation) $ do
(tupleFlavor, closeTok) <- tupleDelimsParser
- mClosed <- MP.optional (expectedTok closeTok)
- case mClosed of
- Just () -> pure (TTuple tupleFlavor Unpromoted [])
- Nothing -> do
- MP.try (tupleConstructorParser tupleFlavor closeTok) <|> parenthesizedTypeOrTupleParser tupleFlavor closeTok
+ closedImmediately <- optionalTok closeTok
+ if closedImmediately
+ then pure (TTuple tupleFlavor Unpromoted [])
+ else MP.try (tupleConstructorParser tupleFlavor closeTok) <|> parenthesizedTypeOrTupleParser tupleFlavor closeTok
where
tupleConstructorParser tupleFlavor closeTok = do
_ <- expectedTok TkSpecialComma
@@ -536,33 +534,33 @@
parenthesizedTypeOrTupleParser tupleFlavor closeTok = do
first <- typeParser
- mKind <- if tupleFlavor == Boxed then MP.optional (expectedTok TkReservedDoubleColon *> typeParser) else pure Nothing
+ mKind <- if tupleFlavor == Boxed then optionalTokThen TkReservedDoubleColon typeParser else pure Nothing
case mKind of
Just kind -> do
expectedTok closeTok
pure (TParen (TKindSig first kind))
Nothing -> do
- mComma <- MP.optional (expectedTok TkSpecialComma)
- case mComma of
- Nothing -> do
+ hasComma <- optionalTok TkSpecialComma
+ if hasComma
+ then do
+ second <- typeParser
+ more <- MP.many (expectedTok TkSpecialComma *> typeParser)
+ expectedTok closeTok
+ pure (TTuple tupleFlavor Unpromoted (first : second : more))
+ else do
-- Check for pipe (unboxed sum type)
- mPipe <- if tupleFlavor == Unboxed then MP.optional (expectedTok TkReservedPipe) else pure Nothing
- case mPipe of
- Just () -> do
+ hasPipe <- if tupleFlavor == Unboxed then optionalTok TkReservedPipe else pure False
+ if hasPipe
+ then do
-- (# Type1 | Type2 | ... #) - unboxed sum type
rest <- typeParser `MP.sepBy1` expectedTok TkReservedPipe
expectedTok closeTok
pure (TUnboxedSum (first : rest))
- Nothing -> do
+ else do
expectedTok closeTok
case tupleFlavor of
Boxed -> pure (TParen first)
Unboxed -> pure (TTuple Unboxed Unpromoted [first])
- Just () -> do
- second <- typeParser
- more <- MP.many (expectedTok TkSpecialComma *> typeParser)
- expectedTok closeTok
- pure (TTuple tupleFlavor Unpromoted (first : second : more))
markTypePromoted :: Type -> Maybe Type
markTypePromoted ty =
diff --git a/src/Aihc/Parser/Lex.hs b/src/Aihc/Parser/Lex.hs
--- a/src/Aihc/Parser/Lex.hs
+++ b/src/Aihc/Parser/Lex.hs
@@ -123,8 +123,8 @@
SkipDone st
| T.null (lexerInput st) -> [eofToken st]
| otherwise ->
- let (tok, st') = nextToken env st
- in tok : scanTokens env (recordScannedToken tok st')
+ case nextToken env st of
+ (tok, st') -> tok : scanTokens env (recordScannedToken tok st')
data SkipResult = SkipDone !LexerState | SkipToken !LexToken !LexerState
@@ -147,8 +147,8 @@
_
| Just rest <- T.stripPrefix "--" inp,
isLineComment rest ->
- let (tok, st') = consumeLineCommentToken st
- in SkipToken tok (markHadTrivia st')
+ case consumeLineCommentToken st of
+ (tok, st') -> SkipToken tok (markHadTrivia st')
-- Check {-# before {- so control pragmas are handled first and
-- block comment handler does not eat pragma tokens.
_
@@ -261,11 +261,11 @@
case scanOneToken env lexSt of
Nothing -> Nothing
Just (rawTok, lexSt') ->
- let (allToks, laySt') = layoutTransition laySt rawTok
- in case allToks of
- [] -> Just (rawTok, lexSt', laySt')
- [first] -> Just (first, lexSt', laySt')
- first : rest -> Just (first, lexSt', laySt' {layoutBuffer = rest})
+ case layoutTransition laySt rawTok of
+ (allToks, laySt') -> case allToks of
+ [] -> Just (rawTok, lexSt', laySt')
+ [first] -> Just (first, lexSt', laySt')
+ first : rest -> Just (first, lexSt', laySt' {layoutBuffer = rest})
scanOneToken :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState)
scanOneToken env st0 =
@@ -281,8 +281,8 @@
st' = st {lexerPrevTokenKind = Just TkEOF, lexerHadTrivia = False}
in Just (tok, st')
| otherwise ->
- let (tok, st') = nextToken env st
- in Just (tok, recordScannedToken tok st')
+ case nextToken env st of
+ (tok, st') -> Just (tok, recordScannedToken tok st')
scanAllTokens :: LexerEnv -> LexerState -> [LexToken]
scanAllTokens env st =
@@ -299,23 +299,25 @@
!firstChunkLen = utf8CharWidth c + identTailBytes hasMagicHash rest
firstChunk = TU.takeWord8 firstChunkLen (lexerInput st)
rest0 = TU.dropWord8 firstChunkLen (lexerInput st)
- (consumed, rest1, isQualified) = gatherQualified hasMagicHash False firstChunk rest0
- in case (isQualified || isConIdStart c, rest1) of
- (True, '.' :< dotRest@(opChar :< _))
- | isSymbolicOpChar opChar ->
- let opChars = T.takeWhile isSymbolicOpChar dotRest
- fullOp = consumed <> "." <> opChars
- (modName, opName) = splitQualified (consumed <> ".") opChars
- kind =
- if opChar == ':'
- then TkQConSym modName opName
- else TkQVarSym modName opName
- st' = advanceChars fullOp st
- in Just (mkToken st st' fullOp kind, st')
- _ ->
- let kind = classifyIdentifier c isQualified consumed
- st' = advanceChars consumed st
- in Just (mkToken st st' consumed kind, st')
+ in case gatherQualified hasMagicHash False firstChunk rest0 of
+ (consumed, rest1, isQualified) ->
+ case rest1 of
+ '.' :< dotRest@(opChar :< _)
+ | isQualified || isConIdStart c,
+ isSymbolicOpChar opChar ->
+ let opChars = T.takeWhile isSymbolicOpChar dotRest
+ fullOp = consumed <> "." <> opChars
+ modName = consumed
+ kind =
+ if opChar == ':'
+ then TkQConSym modName opChars
+ else TkQVarSym modName opChars
+ !st' = advanceChars fullOp st
+ in Just (mkToken st st' fullOp kind, st')
+ _ ->
+ let kind = classifyIdentifier c isQualified consumed
+ !st' = advanceChars consumed st
+ in Just (mkToken st st' consumed kind, st')
_ -> Nothing
where
-- The Bool accumulator records whether a qualifier segment was added.
@@ -326,30 +328,26 @@
| isIdentStart c',
not (T.isSuffixOf "#" acc),
isConIdStart (T.head acc) ->
- let (seg, rest) = consumeIdentTail hasMH more
- segWithHead = TU.takeWord8 (utf8CharWidth c' + TU.lengthWord8 seg) dotRest
- in gatherQualified hasMH True (acc <> "." <> segWithHead) rest
+ case consumeIdentTail hasMH more of
+ (seg, rest) ->
+ let segWithHead = TU.takeWord8 (utf8CharWidth c' + TU.lengthWord8 seg) dotRest
+ in gatherQualified hasMH True (acc <> "." <> segWithHead) rest
_ -> (acc, chars, qualified)
- -- Split a qualified identifier into (module part, name part).
- -- E.g. "Data.Maybe." ++ "++" -> ("Data.Maybe", "++")
- splitQualified :: Text -> Text -> (Text, Text)
- splitQualified modWithDot name =
- (T.dropEnd 1 modWithDot, name)
-
classifyIdentifier firstChar isQualified ident
| isQualified =
let rev = T.reverse ident
- (revName, revRest) = T.span (/= '.') rev
- modName = T.reverse (T.drop 1 revRest)
- name = T.reverse revName
- in case T.uncons name of
- Just (c', _)
- | isConIdStart c' -> TkQConId modName name
- | name == "do" && hasExt QualifiedDo env -> TkQualifiedDo modName
- | name == "mdo" && hasExt QualifiedDo env && hasExt RecursiveDo env -> TkQualifiedMdo modName
- Just _ -> TkQVarId modName name
- Nothing -> TkQVarId modName name
+ in case T.span (/= '.') rev of
+ (revName, revRest) ->
+ let modName = T.reverse (T.drop 1 revRest)
+ name = T.reverse revName
+ in case T.uncons name of
+ Just (c', _)
+ | isConIdStart c' -> TkQConId modName name
+ | name == "do" && hasExt QualifiedDo env -> TkQualifiedDo modName
+ | name == "mdo" && hasExt QualifiedDo env && hasExt RecursiveDo env -> TkQualifiedMdo modName
+ Just _ -> TkQVarId modName name
+ Nothing -> TkQVarId modName name
| otherwise =
case keywordTokenKind (lexerExtensions env) ident of
Just kw -> kw
@@ -458,18 +456,11 @@
other -> other
extendSpanLeft sp =
- case sp of
- SourceSpan {sourceSpanSourceName, sourceSpanEndLine = endLine, sourceSpanEndCol = endCol, sourceSpanEndOffset} ->
- SourceSpan
- { sourceSpanSourceName = sourceSpanSourceName,
- sourceSpanStartLine = lexerLine stBefore,
- sourceSpanStartCol = lexerCol stBefore,
- sourceSpanEndLine = endLine,
- sourceSpanEndCol = endCol,
- sourceSpanStartOffset = lexerByteOffset stBefore,
- sourceSpanEndOffset = sourceSpanEndOffset
- }
- NoSourceSpan -> NoSourceSpan
+ sp
+ { sourceSpanStartLine = lexerLine stBefore,
+ sourceSpanStartCol = lexerCol stBefore,
+ sourceSpanStartOffset = lexerByteOffset stBefore
+ }
-- | Does the token kind represent a primitive (unboxed) numeric literal?
-- These are MagicHash types (Int#, Word#, Float#, Double#) and ExtendedLiterals
diff --git a/src/Aihc/Parser/Lex/Layout.hs b/src/Aihc/Parser/Lex/Layout.hs
--- a/src/Aihc/Parser/Lex/Layout.hs
+++ b/src/Aihc/Parser/Lex/Layout.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Aihc.Parser.Lex.Layout
@@ -8,7 +9,7 @@
where
import Aihc.Parser.Lex.Types
-import Aihc.Parser.Syntax (Extension, SourceSpan (..))
+import Aihc.Parser.Syntax (Extension, SourceSpan)
import Data.Maybe (fromMaybe)
ordinaryLayout :: ImplicitLayoutSpec
@@ -57,13 +58,22 @@
go st toks =
case toks of
[] ->
- let eofAnchor = NoSourceSpan
- (moduleInserted, stAfterModule) = finalizeModuleLayoutAtEOF st eofAnchor
- (pendingInserted, stAfterPending) = flushPendingCaseLayoutAtEOF stAfterModule eofAnchor
- in moduleInserted <> pendingInserted <> closeAllImplicit (layoutContexts stAfterPending) eofAnchor
+ -- The lexer ends every token list with 'TkEOF', and that transition
+ -- closes every open context, so normally nothing is left here. A
+ -- list that ends without 'TkEOF' anchors any remaining virtual
+ -- tokens to the last source token; without one there is nothing to
+ -- anchor them to.
+ case layoutPrevTokenEndSpan st of
+ Nothing -> []
+ Just eofAnchor ->
+ case finalizeModuleLayoutAtEOF st eofAnchor of
+ (moduleInserted, stAfterModule) ->
+ case flushPendingCaseLayoutAtEOF stAfterModule eofAnchor of
+ (pendingInserted, stAfterPending) ->
+ moduleInserted <> pendingInserted <> closeAllImplicit (layoutContexts stAfterPending) eofAnchor
tok : rest ->
- let (emitted, stNext) = layoutTransition st tok
- in emitted <> go stNext rest
+ case layoutTransition st tok of
+ (emitted, stNext) -> emitted <> go stNext rest
finalizeModuleLayoutAtEOF :: LayoutState -> SourceSpan -> ([LexToken], LayoutState)
finalizeModuleLayoutAtEOF st anchor =
@@ -171,9 +181,10 @@
case lexTokenKind tok of
kind
| closesImplicitBeforeDelimiter kind ->
- let (pendingInserted, st0) = flushPendingImplicitLayout st anchor
- (inserted, ctxs') = closeImplicitLayouts anchor (\_ _ -> True) (layoutContexts st0)
- in (pendingInserted <> inserted, st0 {layoutContexts = ctxs'})
+ case flushPendingImplicitLayout st anchor of
+ (pendingInserted, st0) ->
+ case closeImplicitLayouts anchor (\_ _ -> True) (layoutContexts st0) of
+ (inserted, ctxs') -> (pendingInserted <> inserted, st0 {layoutContexts = ctxs'})
| closesImplicitBeforeLayoutKeyword kind ->
closeBeforeLayoutKeyword
_ -> ([], st)
@@ -181,10 +192,11 @@
anchor = lexTokenSpan tok
closeBeforeLayoutKeyword =
- let col = tokenStartCol tok
- (pendingInserted, st0) = flushPendingImplicitLayout st anchor
- (inserted, ctxs') = closeImplicitLayouts anchor (shouldClose col) (layoutContexts st0)
- in (pendingInserted <> inserted, st0 {layoutContexts = ctxs'})
+ let !col = tokenStartCol tok
+ in case flushPendingImplicitLayout st anchor of
+ (pendingInserted, st0) ->
+ case closeImplicitLayouts anchor (shouldClose col) (layoutContexts st0) of
+ (inserted, ctxs') -> (pendingInserted <> inserted, st0 {layoutContexts = ctxs'})
shouldClose col indent kind =
col < indent || (col == indent && closesSameColumnLayout kind)
@@ -225,18 +237,20 @@
bolLayout st tok
| not (isBOL st tok) = ([], st)
| otherwise =
- let col = tokenStartCol tok
- (inserted, contexts') = closeImplicitLayouts (lexTokenSpan tok) (\indent _ -> col < indent) (layoutContexts st)
- semiAnchor = fromMaybe (lexTokenSpan tok) (layoutPrevTokenEndSpan st)
- eqSemi =
- case currentLayoutIndentMaybe contexts' of
- Just indent
- | col == indent,
- currentLayoutAllowsSemicolon contexts',
- lexTokenKind tok /= TkKeywordWhere ->
- [virtualSymbolToken ";" semiAnchor]
- _ -> []
- in (inserted <> eqSemi, st {layoutContexts = contexts'})
+ case closeImplicitLayouts (lexTokenSpan tok) (\indent _ -> col < indent) (layoutContexts st) of
+ (inserted, contexts') ->
+ let semiAnchor = fromMaybe (lexTokenSpan tok) (layoutPrevTokenEndSpan st)
+ eqSemi =
+ case currentLayoutIndentMaybe contexts' of
+ Just indent
+ | col == indent,
+ currentLayoutAllowsSemicolon contexts',
+ lexTokenKind tok /= TkKeywordWhere ->
+ [virtualSymbolToken ";" semiAnchor]
+ _ -> []
+ in (inserted <> eqSemi, st {layoutContexts = contexts'})
+ where
+ !col = tokenStartCol tok
currentLayoutAllowsSemicolon :: [LayoutContext] -> Bool
currentLayoutAllowsSemicolon contexts =
@@ -428,50 +442,60 @@
TkLineComment -> ([tok], st)
TkBlockComment -> ([tok], st)
TkEOF ->
- let eofAnchor = fromMaybe (lexTokenSpan tok) (layoutPrevTokenEndSpan st)
- (moduleInserted, stAfterModule) = finalizeModuleLayoutAtEOF st eofAnchor
- (pendingInserted, stAfterPending) = flushPendingCaseLayoutAtEOF stAfterModule eofAnchor
- in ( moduleInserted <> pendingInserted <> closeAllImplicit (layoutContexts stAfterPending) eofAnchor <> [tok],
- stAfterPending {layoutContexts = [], layoutBuffer = []}
- )
+ let !eofAnchor = fromMaybe (lexTokenSpan tok) (layoutPrevTokenEndSpan st)
+ in case finalizeModuleLayoutAtEOF st eofAnchor of
+ (moduleInserted, stAfterModule) ->
+ case flushPendingCaseLayoutAtEOF stAfterModule eofAnchor of
+ (pendingInserted, stAfterPending) ->
+ ( moduleInserted <> pendingInserted <> closeAllImplicit (layoutContexts stAfterPending) eofAnchor <> [tok],
+ stAfterPending {layoutContexts = [], layoutBuffer = []}
+ )
_ ->
- let stModule = noteModuleLayoutBeforeToken st tok
- (preInserted, stBeforePending) = closeBeforeToken stModule tok
- (pendingInserted, stAfterPending, skipBOL) = openPendingLayout stBeforePending tok
- (bolInserted, stAfterBOL) = if skipBOL then ([], stAfterPending) else bolLayout stAfterPending tok
- stAfterToken = noteModuleLayoutAfterToken (stepTokenContext stAfterBOL tok) tok
- newEndSpan =
- if lexTokenOrigin tok == FromSource
- then Just (lexTokenSpan tok)
- else layoutPrevTokenEndSpan stAfterToken
- stNext =
- stAfterToken
- { layoutPrevTokenKind = Just (lexTokenKind tok),
- layoutPrevTokenEndSpan = newEndSpan,
- layoutBuffer = []
- }
- in (preInserted <> pendingInserted <> bolInserted <> [tok], stNext)
+ -- Every intermediate result is matched with 'case' rather than a lazy
+ -- tuple pattern. A lazy pattern binding here would allocate the pair
+ -- plus a selector thunk per component, on every token of every file;
+ -- matching strictly lets GHC unbox the pairs away entirely.
+ case closeBeforeToken (noteModuleLayoutBeforeToken st tok) tok of
+ (preInserted, stBeforePending) ->
+ case openPendingLayout stBeforePending tok of
+ (pendingInserted, stAfterPending, skipBOL) ->
+ case (if skipBOL then ([], stAfterPending) else bolLayout stAfterPending tok) of
+ (bolInserted, stAfterBOL) ->
+ let !stAfterToken = noteModuleLayoutAfterToken (stepTokenContext stAfterBOL tok) tok
+ newEndSpan =
+ if lexTokenOrigin tok == FromSource
+ then Just (lexTokenSpan tok)
+ else layoutPrevTokenEndSpan stAfterToken
+ !stNext =
+ stAfterToken
+ { layoutPrevTokenKind = Just (lexTokenKind tok),
+ layoutPrevTokenEndSpan = newEndSpan,
+ layoutBuffer = []
+ }
+ in (prependInserted preInserted pendingInserted bolInserted tok, stNext)
{-# INLINE layoutTransition #-}
+-- | The emitted token list for one ordinary token: the virtual tokens the
+-- transition inserted, in order, followed by the token itself.
+--
+-- The overwhelmingly common case is that no virtual token was inserted at all,
+-- and spelling that case out avoids building three @(++)@ thunks per token.
+prependInserted :: [LexToken] -> [LexToken] -> [LexToken] -> LexToken -> [LexToken]
+prependInserted preInserted pendingInserted bolInserted tok =
+ case (preInserted, pendingInserted, bolInserted) of
+ ([], [], []) -> [tok]
+ _ -> preInserted <> (pendingInserted <> (bolInserted <> [tok]))
+{-# INLINE prependInserted #-}
+
closeImplicitLayoutContext :: LayoutState -> Maybe LayoutState
closeImplicitLayoutContext st =
- case layoutContexts st of
- LayoutImplicit _ : rest -> Just (closeWith rest)
+ case (layoutContexts st, layoutPrevTokenEndSpan st) of
+ -- Only a source token opens an implicit context, so an open context always
+ -- has a preceding source token to anchor the virtual brace to.
+ (LayoutImplicit _ : rest, Just anchor) ->
+ Just
+ st
+ { layoutContexts = rest,
+ layoutBuffer = virtualSymbolToken "}" anchor : layoutBuffer st
+ }
_ -> Nothing
- where
- anchor = fromMaybe noSpan (layoutPrevTokenEndSpan st)
- noSpan =
- SourceSpan
- { sourceSpanSourceName = "",
- sourceSpanStartLine = 0,
- sourceSpanStartCol = 0,
- sourceSpanEndLine = 0,
- sourceSpanEndCol = 0,
- sourceSpanStartOffset = 0,
- sourceSpanEndOffset = 0
- }
- closeWith rest =
- st
- { layoutContexts = rest,
- layoutBuffer = virtualSymbolToken "}" anchor : layoutBuffer st
- }
diff --git a/src/Aihc/Parser/Lex/Pragmas.hs b/src/Aihc/Parser/Lex/Pragmas.hs
--- a/src/Aihc/Parser/Lex/Pragmas.hs
+++ b/src/Aihc/Parser/Lex/Pragmas.hs
@@ -306,8 +306,8 @@
_
| Just rest <- T.stripPrefix "LINE" upperBody,
isPragmaBodyEnd rest ->
- let bodyAfter = dropPragmaName "LINE" trimmed
- ws = T.words bodyAfter
+ let afterName = T.stripStart (dropPragmaName "LINE" trimmed)
+ ws = T.words afterName
in case ws of
lineNo : _
| T.all isDigit lineNo ->
@@ -319,7 +319,7 @@
DirectiveUpdate
{ directiveLine = Just parsedLine,
directiveCol = Just 1,
- directiveSourceName = parseDirectiveSourceName (T.dropWhile isSpace (T.drop (T.length lineNo) bodyAfter))
+ directiveSourceName = parseDirectiveSourceName (T.drop (T.length lineNo) afterName)
}
)
Nothing -> Just ("{-#" <> body <> "#-}", Left "malformed LINE pragma")
@@ -342,14 +342,14 @@
_ -> Just ("{-#" <> body <> "#-}", Left "malformed COLUMN pragma")
_ -> Nothing
-parseDirectiveSourceName :: Text -> Maybe FilePath
+parseDirectiveSourceName :: Text -> Maybe Text
parseDirectiveSourceName rest =
let rest' = T.dropWhile isSpace rest
in case rest' of
'"' :< more ->
let (name, trailing) = T.break (== '"') more
in case trailing of
- '"' :< _ -> Just (T.unpack name)
+ '"' :< _ -> Just name
_ -> Nothing
_ -> Nothing
diff --git a/src/Aihc/Parser/Lex/Trivia.hs b/src/Aihc/Parser/Lex/Trivia.hs
--- a/src/Aihc/Parser/Lex/Trivia.hs
+++ b/src/Aihc/Parser/Lex/Trivia.hs
@@ -195,14 +195,14 @@
c :< _ | isDigit c -> True
_ -> "line" `T.isPrefixOf` afterHash
-parseDirectiveSourceName :: Text -> Maybe FilePath
+parseDirectiveSourceName :: Text -> Maybe Text
parseDirectiveSourceName rest =
let rest' = T.dropWhile isSpace rest
in case rest' of
'"' :< more ->
let (name, trailing) = T.break (== '"') more
in case trailing of
- '"' :< _ -> Just (T.unpack name)
+ '"' :< _ -> Just name
_ -> Nothing
_ -> Nothing
diff --git a/src/Aihc/Parser/Lex/Types.hs b/src/Aihc/Parser/Lex/Types.hs
--- a/src/Aihc/Parser/Lex/Types.hs
+++ b/src/Aihc/Parser/Lex/Types.hs
@@ -226,7 +226,7 @@
data LexerState = LexerState
{ lexerInput :: !Text,
- lexerLogicalSourceName :: !FilePath,
+ lexerLogicalSourceName :: !Text,
lexerLine :: !Int,
lexerCol :: !Int,
lexerByteOffset :: !Int,
@@ -307,7 +307,7 @@
data DirectiveUpdate = DirectiveUpdate
{ directiveLine :: !(Maybe Int),
directiveCol :: !(Maybe Int),
- directiveSourceName :: !(Maybe FilePath)
+ directiveSourceName :: !(Maybe Text)
}
deriving (Eq, Show)
@@ -325,7 +325,7 @@
( mkLexerEnv exts,
LexerState
{ lexerInput = input,
- lexerLogicalSourceName = sourceName,
+ lexerLogicalSourceName = T.pack sourceName,
lexerLine = 1,
lexerCol = 1,
lexerByteOffset = 0,
@@ -456,10 +456,7 @@
in go 0 (lexerLine st) (lexerCol st) (lexerByteOffset st) (lexerAtLineStart st)
tokenStartCol :: LexToken -> Int
-tokenStartCol tok =
- case lexTokenSpan tok of
- SourceSpan {sourceSpanStartCol = col} -> col
- NoSourceSpan -> 1
+tokenStartCol tok = sourceSpanStartCol (lexTokenSpan tok)
virtualSymbolToken :: Text -> SourceSpan -> LexToken
virtualSymbolToken sym span' =
diff --git a/src/Aihc/Parser/Syntax.hs b/src/Aihc/Parser/Syntax.hs
--- a/src/Aihc/Parser/Syntax.hs
+++ b/src/Aihc/Parser/Syntax.hs
@@ -1,6 +1,8 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE ViewPatterns #-}
-- |
--
@@ -85,7 +87,15 @@
Role (..),
RoleAnnotation (..),
Rhs (..),
- SourceSpan (..),
+ SourceSpan,
+ pattern SourceSpan,
+ sourceSpanSourceName,
+ sourceSpanStartLine,
+ sourceSpanStartCol,
+ sourceSpanEndLine,
+ sourceSpanEndCol,
+ sourceSpanStartOffset,
+ sourceSpanEndOffset,
StandaloneDerivingDecl (..),
Type (..),
TupleFlavor (..),
@@ -120,7 +130,6 @@
gadtBodyResultType,
languageEditionExtensions,
editionFromExtensionSettings,
- noSourceSpan,
mergeSourceSpans,
mkName,
mkUnqualifiedName,
@@ -160,14 +169,13 @@
where
import Control.DeepSeq (NFData (..))
-import Data.Bits (setBit, testBit)
+import Data.Bits (clearBit, countTrailingZeros, setBit, shiftL, shiftR, testBit, (.&.), (.|.))
import Data.Char (GeneralCategory (..), generalCategory)
import Data.Data (Constr, Data (..), DataType, Fixity (Prefix), mkConstr, mkDataType)
import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn)
-import Data.List (sort)
import Data.List qualified as List
import Data.Map qualified as Map
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe)
import Data.String (IsString (..))
import Data.Text (Text)
import Data.Text qualified as T
@@ -344,14 +352,37 @@
deriving anyclass (NFData)
mkExtensionSet :: [Extension] -> ExtensionSet
-mkExtensionSet = List.foldl' insertExtension (ExtensionSet 0 0 0)
+mkExtensionSet = List.foldl' (flip insertExtension) emptyExtensionSet
+
+emptyExtensionSet :: ExtensionSet
+emptyExtensionSet = ExtensionSet 0 0 0
+
+insertExtension :: Extension -> ExtensionSet -> ExtensionSet
+insertExtension ext (ExtensionSet low middle high) =
+ case fromEnum ext `quotRem` 64 of
+ (0, bit) -> ExtensionSet (setBit low bit) middle high
+ (1, bit) -> ExtensionSet low (setBit middle bit) high
+ (2, bit) -> ExtensionSet low middle (setBit high bit)
+ _ -> error "insertExtension: extension enum exceeds bitset capacity"
+
+deleteExtension :: Extension -> ExtensionSet -> ExtensionSet
+deleteExtension ext (ExtensionSet low middle high) =
+ case fromEnum ext `quotRem` 64 of
+ (0, bit) -> ExtensionSet (clearBit low bit) middle high
+ (1, bit) -> ExtensionSet low (clearBit middle bit) high
+ (2, bit) -> ExtensionSet low middle (clearBit high bit)
+ _ -> error "deleteExtension: extension enum exceeds bitset capacity"
+
+-- | The members of the set, in 'Extension' constructor order.
+extensionSetToList :: ExtensionSet -> [Extension]
+extensionSetToList (ExtensionSet low middle high) =
+ wordMembers 0 low (wordMembers 64 middle (wordMembers 128 high []))
where
- insertExtension (ExtensionSet low middle high) ext =
- case fromEnum ext `quotRem` 64 of
- (0, bit) -> ExtensionSet (setBit low bit) middle high
- (1, bit) -> ExtensionSet low (setBit middle bit) high
- (2, bit) -> ExtensionSet low middle (setBit high bit)
- _ -> error "mkExtensionSet: extension enum exceeds bitset capacity"
+ wordMembers base word rest
+ | word == 0 = rest
+ | otherwise =
+ let bit = countTrailingZeros word
+ in toEnum (base + bit) : wordMembers base (clearBit word bit) rest
memberExtension :: Extension -> ExtensionSet -> Bool
memberExtension ext (ExtensionSet low middle high) =
@@ -655,12 +686,32 @@
impliedExtensionMap :: Map.Map Extension [ExtensionSetting]
impliedExtensionMap = Map.fromList impliedExtensions
+-- | Close a set of extensions under 'impliedExtensions'.
+--
+-- The fixpoint runs on the 'ExtensionSet' bitset rather than on the list:
+-- enabling or disabling one extension is then a word operation instead of a
+-- filter over every extension already enabled, and comparing two rounds is a
+-- comparison of three words instead of sorting two lists. The result is
+-- returned in 'Extension' constructor order; only membership is meaningful,
+-- and the caller's own list is handed back untouched when it is already
+-- closed.
applyImpliedExtensions :: [Extension] -> [Extension]
-applyImpliedExtensions extensions =
- let settings = concat $ mapMaybe (`Map.lookup` impliedExtensionMap) extensions
- newExtensions = foldr applyExtensionSetting extensions settings
- in if sort newExtensions == sort extensions then extensions else applyImpliedExtensions newExtensions
+applyImpliedExtensions extensions
+ | closure == initial = extensions
+ | otherwise = extensionSetToList closure
+ where
+ initial = mkExtensionSet extensions
+ closure = go initial
+ go current =
+ let settings = concatMap impliedBy (extensionSetToList current)
+ next = foldr applySettingToSet current settings
+ in if next == current then current else go next
+ impliedBy ext = Map.findWithDefault [] ext impliedExtensionMap
+applySettingToSet :: ExtensionSetting -> ExtensionSet -> ExtensionSet
+applySettingToSet (EnableExtension ext) = insertExtension ext
+applySettingToSet (DisableExtension ext) = deleteExtension ext
+
-- | Apply 'LANGUAGE' settings left to right, the order GHC applies them in,
-- so that a later setting overrides an earlier one. Implications are applied
-- immediately after each enable, so a later explicit disable can override an
@@ -671,25 +722,96 @@
applyOne extensions setting@(EnableExtension _) = applyImpliedExtensions (applyExtensionSetting setting extensions)
applyOne extensions setting@(DisableExtension _) = applyExtensionSetting setting extensions
--- | Source location metadata for parsed syntax.
--- Example: the span covering @map@ in @map f xs@.
+-- | Source location metadata for parsed syntax, such as the token range for
+-- @map@ in @map f xs@.
+--
+-- A span is always concrete. Syntax without a location carries no
+-- 'SourceSpan' annotation at all, so consumers read a span with
+-- 'fromAnnotation' and treat its absence as the missing case.
+--
+-- A span is flat: the source name is a 'Text' that every span from the same
+-- file shares, and the positions are unboxed, so a span in weak head normal
+-- form is already in normal form and 'rnf' on it is constant time.
+--
+-- Line, column and byte-offset numbers are non-negative and far below @2^32@
+-- even for machine-generated sources, so the six of them are packed two to a
+-- word. A span is a third smaller as a result, which matters because it is
+-- the single most numerous heap object in a parse tree. The packing is an
+-- implementation detail: the 'SourceSpan' pattern synonym below constructs
+-- and matches spans in terms of the same seven fields as before.
+--
+-- Six @{-\# UNPACK \#-} !Word32@ fields would give exactly the same five-word
+-- closure, because GHC packs unpacked sub-word fields two to a machine word,
+-- and would need no shifting here. It was measured and is about 3% slower on
+-- the @bench-aihc-base@ benchmark at byte-identical allocation, so the
+-- explicit packing stays.
data SourceSpan
- = -- | No location information is available.
- NoSourceSpan
- | -- | A concrete span such as the token range for @map@ in @map f xs@.
- SourceSpan
- { sourceSpanSourceName :: !FilePath,
- sourceSpanStartLine :: !Int,
- sourceSpanStartCol :: !Int,
- sourceSpanEndLine :: !Int,
- sourceSpanEndCol :: !Int,
- sourceSpanStartOffset :: !Int,
- sourceSpanEndOffset :: !Int
- }
- deriving (Data, Eq, Ord, Generic, NFData)
+ = PackedSourceSpan
+ -- | The file the span refers to, as given to the parser or by a
+ -- @LINE@ pragma or @#line@ directive.
+ !Text
+ -- | Start line in the high half, start column in the low half.
+ {-# UNPACK #-} !Word64
+ -- | End line in the high half, end column in the low half.
+ {-# UNPACK #-} !Word64
+ -- | Start byte offset in the high half, end byte offset in the low half.
+ {-# UNPACK #-} !Word64
+ deriving (Data, Eq, Ord, Generic)
+-- | A concrete span, in terms of its seven logical fields.
+--
+-- Deriving 'Ord' on the packed representation gives the same ordering as
+-- deriving it on these fields, because each pair is packed most-significant
+-- component first and in the same order.
+pattern SourceSpan ::
+ Text -> Int -> Int -> Int -> Int -> Int -> Int -> SourceSpan
+pattern SourceSpan
+ { sourceSpanSourceName,
+ sourceSpanStartLine,
+ sourceSpanStartCol,
+ sourceSpanEndLine,
+ sourceSpanEndCol,
+ sourceSpanStartOffset,
+ sourceSpanEndOffset
+ } <-
+ PackedSourceSpan
+ sourceSpanSourceName
+ (unpackPositions -> (sourceSpanStartLine, sourceSpanStartCol))
+ (unpackPositions -> (sourceSpanEndLine, sourceSpanEndCol))
+ (unpackPositions -> (sourceSpanStartOffset, sourceSpanEndOffset))
+ where
+ SourceSpan name startLine startCol endLine endCol startOffset endOffset =
+ PackedSourceSpan
+ name
+ (packPositions startLine startCol)
+ (packPositions endLine endCol)
+ (packPositions startOffset endOffset)
+
+{-# COMPLETE SourceSpan #-}
+
+packPositions :: Int -> Int -> Word64
+packPositions high low =
+ (fromIntegral high `shiftL` 32) .|. (fromIntegral low .&. 0xffffffff)
+{-# INLINE packPositions #-}
+
+unpackPositions :: Word64 -> (Int, Int)
+unpackPositions word = (highPosition word, lowPosition word)
+{-# INLINE unpackPositions #-}
+
+highPosition :: Word64 -> Int
+highPosition word = fromIntegral (word `shiftR` 32)
+{-# INLINE highPosition #-}
+
+lowPosition :: Word64 -> Int
+lowPosition word = fromIntegral (word .&. 0xffffffff)
+{-# INLINE lowPosition #-}
+
+-- | Every field is strict and none of them holds a thunk once the span is in
+-- weak head normal form, so forcing the span is all there is to do.
+instance NFData SourceSpan where
+ rnf span' = span' `seq` ()
+
instance Show SourceSpan where
- show NoSourceSpan = "NoSourceSpan"
show SourceSpan {sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndLine, sourceSpanEndCol} =
"SourceSpan "
++ show sourceSpanStartLine
@@ -700,18 +822,17 @@
++ " "
++ show sourceSpanEndCol
-noSourceSpan :: SourceSpan
-noSourceSpan = NoSourceSpan
-
+-- | The span from the start of the first span to the end of the second.
+-- The source name comes from the first span.
mergeSourceSpans :: SourceSpan -> SourceSpan -> SourceSpan
-mergeSourceSpans left right =
- case (left, right) of
- ( SourceSpan name l1 c1 _ _ startOffset _,
- SourceSpan _ _ _ l2 c2 _ endOffset
- ) ->
- SourceSpan name l1 c1 l2 c2 startOffset endOffset
- (NoSourceSpan, span') -> span'
- (span', NoSourceSpan) -> span'
+mergeSourceSpans
+ (PackedSourceSpan name start _ startOffsets)
+ (PackedSourceSpan _ _ end endOffsets) =
+ PackedSourceSpan
+ name
+ start
+ end
+ (packPositions (highPosition startOffsets) (lowPosition endOffsets))
-- | A qualified or unqualified name with type information.
--
@@ -1987,7 +2108,7 @@
instance Data Annotation where
gfoldl _ z = z
- gunfold _ z _ = z (SourceSpanAnnotation NoSourceSpan)
+ gunfold _ z _ = z (DynamicAnnotation (toDyn ()))
toConstr _ = annotationConstr
dataTypeOf _ = annotationDataType
diff --git a/src/Aihc/Parser/Types.hs b/src/Aihc/Parser/Types.hs
--- a/src/Aihc/Parser/Types.hs
+++ b/src/Aihc/Parser/Types.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
module Aihc.Parser.Types
@@ -17,6 +18,8 @@
mkFoundToken,
ParseErrorBundle,
ParseResult (..),
+ rebuildStream,
+ sourcePosSpan,
ParserConfig (..),
)
where
@@ -33,7 +36,7 @@
readModuleHeaderExtensions,
scanAllTokens,
)
-import Aihc.Parser.Syntax (Extension, ExtensionSet, SourceSpan, applyExtensionSetting, applyImpliedExtensions, mkExtensionSet)
+import Aihc.Parser.Syntax (Extension, ExtensionSet, SourceSpan, applyExtensionSetting, applyImpliedExtensions, mkExtensionSet, sourceSpanEndCol, sourceSpanEndLine, sourceSpanEndOffset, sourceSpanSourceName, sourceSpanStartCol, sourceSpanStartLine, sourceSpanStartOffset, pattern SourceSpan)
import Control.DeepSeq (NFData (..))
import Data.Text (Text)
import Data.Text qualified as T
@@ -252,8 +255,8 @@
case rawTokens' of
[] -> finish [] layoutState' [] pendingPragmas'
rawTok : rawRest ->
- let (allToks, laySt') = layoutTransition layoutState' rawTok
- in go rawRest laySt' allToks pendingPragmas'
+ case layoutTransition layoutState' rawTok of
+ (allToks, laySt') -> go rawRest laySt' allToks pendingPragmas'
-- | Step one token from the stream. This is the core primitive used by all
-- Stream methods; its result is memoized in 'tokStreamNext'.
@@ -300,6 +303,31 @@
in Just (tok, next)
[] ->
Nothing
+
+-- | Build a stream a second time, for locating errors after a parse.
+--
+-- Error rendering walks a stream from offset 0. Reusing the stream that was
+-- parsed would keep its memoized successor chain alive for the whole parse,
+-- which 'runTokStreamParser' is careful to avoid. This function is not
+-- inlined so that GHC cannot share the rebuilt stream with the parsed one by
+-- common-subexpression elimination.
+rebuildStream :: (a -> TokStream) -> a -> TokStream
+rebuildStream build = build
+{-# NOINLINE rebuildStream #-}
+
+-- | The zero-width span at a Megaparsec source position, such as the initial
+-- position of a parse. Used when a stream has no token to locate something at.
+sourcePosSpan :: MP.SourcePos -> SourceSpan
+sourcePosSpan pos =
+ SourceSpan
+ { sourceSpanSourceName = T.pack (MP.sourceName pos),
+ sourceSpanStartLine = MP.unPos (MP.sourceLine pos),
+ sourceSpanStartCol = MP.unPos (MP.sourceColumn pos),
+ sourceSpanEndLine = MP.unPos (MP.sourceLine pos),
+ sourceSpanEndCol = MP.unPos (MP.sourceColumn pos),
+ sourceSpanStartOffset = 0,
+ sourceSpanEndOffset = 0
+ }
-- | Run a token parser from the start of a stream.
--
diff --git a/test/Spec.hs b/test/Spec.hs
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -240,6 +240,7 @@
testCase "lexes string gaps before a closing quote" test_stringGapBeforeClosingQuoteLexes,
testCase "pretty-prints overloaded labels with delimiter spacing" test_overloadedLabelPrettyPrintsWithDelimiterSpacing,
testCase "applies LINE pragmas to subsequent tokens" test_linePragmaUpdatesSpan,
+ testCase "applies a LINE pragma file name to subsequent tokens" test_linePragmaUpdatesSourceName,
testCase "applies COLUMN pragmas to subsequent tokens" test_columnPragmaUpdatesSpan,
testCase "applies COLUMN pragmas in the middle of a line" test_inlineColumnPragmaUpdatesSpan,
testCase "sets lexTokenAtLineStart correctly" test_tokenAtLineStartWithoutDirective,
@@ -261,6 +262,7 @@
testCase "shrunk standalone kind signatures shrink binder kinds" test_shrunkStandaloneKindSignaturesShrinkBinderKinds,
testCase "shrunk module headers without warnings make progress" test_shrunkModuleHeaderWithoutWarningMakesProgress,
testCase "syntax utility functions cover public edge cases" test_syntaxUtilityFunctions,
+ testCase "parse errors without a token are located at the parser offset" test_parseErrorOffsetSpan,
testCase "shrunk class default pattern binds make progress" test_shrunkClassDefaultPatternBindMakesProgress,
testCase "parsed binders carry source spans" test_parsedBindersCarrySourceSpans,
testCase "every top-level declaration carries a source span" test_everyTopLevelDeclarationCarriesSourceSpan,
@@ -532,6 +534,13 @@
assertSourceSpan "" 17 1 17 2 16 17 span'
other -> assertFailure ("expected identifier at line 17, got: " <> show other)
+test_linePragmaUpdatesSourceName :: Assertion
+test_linePragmaUpdatesSourceName =
+ case lexTokens "{-# LINE 14 \"Demo.hsc\" #-}\nx" of
+ [LexToken {lexTokenKind = TkVarId "x", lexTokenSpan = span'}, LexToken {lexTokenKind = TkEOF}] ->
+ assertSourceSpan "Demo.hsc" 14 1 14 2 27 28 span'
+ other -> assertFailure ("expected identifier at Demo.hsc line 14, got: " <> show other)
+
test_columnPragmaUpdatesSpan :: Assertion
test_columnPragmaUpdatesSpan =
case lexTokens "x\n{-# COLUMN 7 #-}y" of
@@ -733,20 +742,17 @@
] -> pure ()
other -> assertFailure ("expected indented '# line' to lex as operator + identifier, got: " <> show other)
-assertSourceSpan :: FilePath -> Int -> Int -> Int -> Int -> Int -> Int -> SourceSpan -> Assertion
-assertSourceSpan expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset span' =
- case span' of
- SourceSpan {sourceSpanSourceName, sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndLine, sourceSpanEndCol, sourceSpanStartOffset, sourceSpanEndOffset} -> do
- assertEqual "source name" expectedName sourceSpanSourceName
- assertEqual "start line" expectedStartLine sourceSpanStartLine
- assertEqual "start col" expectedStartCol sourceSpanStartCol
- assertEqual "end line" expectedEndLine sourceSpanEndLine
- assertEqual "end col" expectedEndCol sourceSpanEndCol
- assertEqual "start offset" expectedStartOffset sourceSpanStartOffset
- assertEqual "end offset" expectedEndOffset sourceSpanEndOffset
- NoSourceSpan -> assertFailure "expected SourceSpan, got NoSourceSpan"
+assertSourceSpan :: Text -> Int -> Int -> Int -> Int -> Int -> Int -> SourceSpan -> Assertion
+assertSourceSpan expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset SourceSpan {sourceSpanSourceName, sourceSpanStartLine, sourceSpanStartCol, sourceSpanEndLine, sourceSpanEndCol, sourceSpanStartOffset, sourceSpanEndOffset} = do
+ assertEqual "source name" expectedName sourceSpanSourceName
+ assertEqual "start line" expectedStartLine sourceSpanStartLine
+ assertEqual "start col" expectedStartCol sourceSpanStartCol
+ assertEqual "end line" expectedEndLine sourceSpanEndLine
+ assertEqual "end col" expectedEndCol sourceSpanEndCol
+ assertEqual "start offset" expectedStartOffset sourceSpanStartOffset
+ assertEqual "end offset" expectedEndOffset sourceSpanEndOffset
-assertUnqualifiedNameSpan :: String -> FilePath -> Int -> Int -> Int -> Int -> Int -> Int -> UnqualifiedName -> Assertion
+assertUnqualifiedNameSpan :: String -> Text -> Int -> Int -> Int -> Int -> Int -> Int -> UnqualifiedName -> Assertion
assertUnqualifiedNameSpan label expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset name =
case mapMaybe (fromAnnotation :: Annotation -> Maybe SourceSpan) (unqualifiedNameAnns name) of
span' : _ -> assertSourceSpan expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset span'
@@ -757,6 +763,16 @@
mapM_ $ \value ->
assertEqual (label <> ": " <> show value) (Just value) (readMaybe (show value))
+-- A `fail` inside the parser raises an error that names no token. Its span
+-- is recovered from the error offset: the token the parser stood on.
+test_parseErrorOffsetSpan :: Assertion
+test_parseErrorOffsetSpan =
+ case parseModule defaultConfig "{-# LANGUAGE TransformListComp #-}\nx = [y | y <- ys, then group z]" of
+ ([(span', message)], _) -> do
+ assertEqual "message" "expected 'by' or 'using' after 'group'" message
+ assertSourceSpan "" 2 30 2 31 64 65 span'
+ (errs, _) -> assertFailure ("expected exactly one parse error, got: " <> show errs)
+
test_syntaxUtilityFunctions :: Assertion
test_syntaxUtilityFunctions = do
assertEqual "known extensions" ([minBound .. maxBound] :: [Extension]) allKnownExtensions
@@ -794,11 +810,8 @@
let spanA = SourceSpan "A.hs" 1 2 1 4 0 2
spanB = SourceSpan "A.hs" 2 1 2 5 3 7
merged = SourceSpan "A.hs" 1 2 2 5 0 7
- assertEqual "show no source span" "NoSourceSpan" (show noSourceSpan)
assertEqual "show source span" "SourceSpan 1 2 2 5" (show merged)
assertEqual "merge source spans" merged (mergeSourceSpans spanA spanB)
- assertEqual "merge left missing source span" spanB (mergeSourceSpans NoSourceSpan spanB)
- assertEqual "merge right missing source span" spanA (mergeSourceSpans spanA NoSourceSpan)
assertBool "source span ordering" (spanA < spanB)
assertBool "source span nfdata" (rnf merged `seq` True)
diff --git a/test/Test/Properties/NoExceptions.hs b/test/Test/Properties/NoExceptions.hs
--- a/test/Test/Properties/NoExceptions.hs
+++ b/test/Test/Properties/NoExceptions.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Test.Properties.NoExceptions
@@ -31,7 +32,7 @@
parsePatternFromTokens,
parseTypeFromTokens,
)
-import Aihc.Parser.Syntax (ExtensionSetting (..), FloatType (..), NumericType (..), SourceSpan (..))
+import Aihc.Parser.Syntax (ExtensionSetting (..), FloatType (..), NumericType (..), SourceSpan, pattern SourceSpan)
import Aihc.Parser.Syntax qualified as Syntax
import Control.DeepSeq (NFData (..), force)
import Control.Exception (SomeException, evaluate, try)
@@ -326,36 +327,30 @@
]
genSourceSpan :: Gen SourceSpan
-genSourceSpan =
- oneof
- [ pure NoSourceSpan,
- do
- sourceName <- elements ["", "source", "generated.h"]
- startLine <- chooseInt (1, 200)
- startCol <- chooseInt (1, 200)
- endLine <- chooseInt (startLine, startLine + 5)
- endCol <-
- if endLine == startLine
- then chooseInt (startCol, startCol + 10)
- else chooseInt (1, 200)
- startOffset <- chooseInt (0, 4000)
- endOffset <- chooseInt (startOffset, startOffset + 200)
- pure (SourceSpan sourceName startLine startCol endLine endCol startOffset endOffset)
- ]
+genSourceSpan = do
+ sourceName <- elements ["", "source", "generated.h"]
+ startLine <- chooseInt (1, 200)
+ startCol <- chooseInt (1, 200)
+ endLine <- chooseInt (startLine, startLine + 5)
+ endCol <-
+ if endLine == startLine
+ then chooseInt (startCol, startCol + 10)
+ else chooseInt (1, 200)
+ startOffset <- chooseInt (0, 4000)
+ endOffset <- chooseInt (startOffset, startOffset + 200)
+ pure (SourceSpan sourceName startLine startCol endLine endCol startOffset endOffset)
shrinkSourceSpan :: SourceSpan -> [SourceSpan]
shrinkSourceSpan span' =
case span' of
- NoSourceSpan -> []
SourceSpan sourceName sl sc el ec startOffset endOffset ->
- [NoSourceSpan]
- <> [ SourceSpan sourceName sl' sc' el' ec' startOffset' endOffset'
- | (sl', sc', el', ec', startOffset', endOffset') <- shrink (sl, sc, el, ec, startOffset, endOffset),
- sl' >= 1,
- sc' >= 1,
- el' >= sl',
- ec' >= 1,
- el' > sl' || ec' >= sc',
- startOffset' >= 0,
- endOffset' >= startOffset'
- ]
+ [ SourceSpan sourceName sl' sc' el' ec' startOffset' endOffset'
+ | (sl', sc', el', ec', startOffset', endOffset') <- shrink (sl, sc, el, ec, startOffset, endOffset),
+ sl' >= 1,
+ sc' >= 1,
+ el' >= sl',
+ ec' >= 1,
+ el' > sl' || ec' >= sc',
+ startOffset' >= 0,
+ endOffset' >= startOffset'
+ ]