aihc-parser 3.0.1.1 → 4.0.0.0

raw patch · 22 files changed

+1166/−608 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +99/−0
• aihc-parser.cabal +1/−1
• src/Aihc/Parser.hs +50/−61
• src/Aihc/Parser/Internal/Cmd.hs +9/−9
• src/Aihc/Parser/Internal/Common.hs +208/−52
• src/Aihc/Parser/Internal/Decl.hs +80/−55
• src/Aihc/Parser/Internal/Errors.hs +42/−8
• src/Aihc/Parser/Internal/Expr.hs +203/−111
• src/Aihc/Parser/Internal/FromTokens.hs +1/−1
• src/Aihc/Parser/Internal/Import.hs +10/−10
• src/Aihc/Parser/Internal/Module.hs +10/−8
• src/Aihc/Parser/Internal/Pattern.hs +27/−33
• src/Aihc/Parser/Internal/Type.hs +25/−27
• src/Aihc/Parser/Lex.hs +50/−59
• src/Aihc/Parser/Lex/Layout.hs +91/−67
• src/Aihc/Parser/Lex/Pragmas.hs +5/−5
• src/Aihc/Parser/Lex/Trivia.hs +2/−2
• src/Aihc/Parser/Lex/Types.hs +4/−7
• src/Aihc/Parser/Syntax.hs +165/−44
• src/Aihc/Parser/Types.hs +31/−3
• test/Spec.hs +29/−16
• test/Test/Properties/NoExceptions.hs +24/−29

@@ -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

@@ -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

@@ -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 "<input>" "x = 1" (SourceSpan 1 5 1 6) = """+-- renderSourceReference "x = 1" (SourceSpan "<input>" 1 5 1 6 4 5) = """ -- <input>:1:5: -- 1 | x = 1 --   |     ^ -- """--- renderSourceReference "<input>" "module where" (SourceSpan 1 8 1 13) = """--- <input>:1:5:+-- renderSourceReference "module where" (SourceSpan "<input>" 1 8 1 13 7 12) = """+-- <input>: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)

@@ -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,

@@ -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

@@ -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,

@@ -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

@@ -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<qcon> '{' 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

@@ -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

@@ -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' ->

@@ -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)

@@ -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

@@ -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 =

@@ -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

@@ -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-        }

@@ -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 

@@ -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 

@@ -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' =

@@ -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 

@@ -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. --

@@ -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 "<input>" 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 "<input>" 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) 

@@ -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 ["<input>", "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 ["<input>", "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'+      ]