aihc-parser 5.0.1.0 → 6.0.0.0

raw patch · 29 files changed

+1064/−207 lines, 29 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +60/−0
• aihc-parser.cabal +1/−1
• common/ExtensionSupport.hs +14/−9
• src/Aihc/Parser.hs +52/−5
• src/Aihc/Parser/Internal/CheckPattern.hs +69/−30
• src/Aihc/Parser/Internal/Cmd.hs +1/−1
• src/Aihc/Parser/Internal/Common.hs +117/−9
• src/Aihc/Parser/Internal/Decl.hs +47/−13
• src/Aihc/Parser/Internal/Expr.hs +3/−3
• src/Aihc/Parser/Internal/Import.hs +6/−2
• src/Aihc/Parser/Internal/Module.hs +10/−3
• src/Aihc/Parser/Internal/Pattern.hs +58/−9
• src/Aihc/Parser/Internal/Type.hs +9/−1
• src/Aihc/Parser/Parens.hs +34/−2
• src/Aihc/Parser/Pretty.hs +239/−109
• src/Aihc/Parser/Shorthand.hs +1/−0
• src/Aihc/Parser/Syntax.hs +3/−0
• src/Aihc/Parser/Types.hs +99/−6
• test/Spec.hs +109/−3
• test/Test/Fixtures/golden/pattern/n-plus-k.yaml +6/−0
• test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-casealt.hs +8/−0
• test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-funarg.hs +7/−0
• test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-patbind.hs +12/−0
• test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-typed-patbind.hs +11/−0
• test/Test/Fixtures/oracle/TransformListComp/transform-case-before-keyword.hs +8/−0
• test/Test/Fixtures/oracle/TransformListComp/transform-multiway-if-before-keyword.hs +9/−0
• test/Test/Oracle/Suite.hs +57/−1
• test/Test/Properties/Arb/Pattern.hs +13/−0
• test/Test/Properties/Arb/Utils.hs +1/−0

@@ -6,6 +6,66 @@  ## [Unreleased] +## [6.0.0.0] - 2026-11-12++### Added++- The parser accepts n+k patterns, for example `f (n+1) = n`, when the+  `NPlusKPatterns` extension is on. `Haskell98` turns on this extension. The+  new `PNPlusK` constructor of `Pattern` holds the variable and the integer+  literal. A function or pattern that matches on all `Pattern` constructors+  must add a case for `PNPlusK`.+- With `NPlusKPatterns` on, `(n+1) = e` is a pattern binding, as in GHC.+  Without parentheses, `n + 1 = e` is still a definition of `(+)`.+- `parseModuleWithTrace` parses a module and also returns its token trace.+  The trace has each token that the parser took, in order. It has real+  tokens and virtual layout tokens. A `TraceEntry` marks each token that the+  parser took but did not keep in the AST, for example a trailing comma, an+  extra semicolon, or the parentheses of `data (T a) = …`.+- `tokenKindWithoutSpacing` maps a token kind to the kind that it has with+  spaces around it, for example `TkPrefixPercent` to `TkVarSym "%"`.+- When the discarded entries are removed, a module and its pretty-printed+  form have the same trace token kinds. A formatter can use this to pair the+  tokens of the two texts.++### Changed++- The pretty-printer puts an expression on one line when it fits in the+  page width. For example, it prints `f x = x + 1` on one line. Before, it+  put each operator and each function argument on a new line. A long+  expression still breaks at the same points as before. Layout blocks+  (`do`, `case`, `where`, `let`, guards, and multi-way `if`) still start new+  lines where the layout rule needs them.+- When a function application does not fit, the pretty-printer puts as many+  arguments on a line as fit. Before, it put each argument on its own line.+  After an argument that ends with a layout block, a new line still starts.+- When a record construction, a record update, a list, or a tuple does not+  fit, the pretty-printer starts a new line after each comma. Before, it kept+  all items on one line.+- When a function type does not fit, each argument after the first starts a+  new line with its arrow. A context that does not fit puts the rest on a new+  line after `=>`. This also applies to instance heads and class heads.+- When a `data` or `newtype` declaration does not fit, each constructor and+  each deriving clause starts a new line. A record declaration that does not+  fit starts a new line after each field.+- When an import list or an export list does not fit, each line gets as many+  items as fit.++### Fixed++- The pretty-printer does not put parentheses around a `case` expression+  before `by` or `using` in a TransformListComp statement. With+  TransformListComp, these words are keywords and they close the case+  alternatives. Before, GHC read the printed module with an extra `HsPar`.+- The pretty-printer also does not put parentheses around a multi-way `if`+  before `by` or `using` in a TransformListComp statement. The keyword+  closes the alternatives of the multi-way `if`.+- The pretty-printer puts the alternatives of a multi-way `if` to the right of+  the current indentation. Before, a continuation line of the expression+  around the `if` could start at the column of the `|` of an alternative. The+  parser then read that line as part of the last alternative, and the printed+  module did not parse to the same syntax tree.+ ## [5.0.1.0] - 2026-10-21  ### Added

@@ -1,6 +1,6 @@ cabal-version: 3.8 name: aihc-parser-version: 5.0.1.0+version: 6.0.0.0 build-type: Simple license: Unlicense license-file: LICENSE

@@ -12,6 +12,7 @@     finalizeOutcome,     evaluateCaseFromFile,     evaluateCaseText,+    preprocessCaseSource,   ) where @@ -80,18 +81,22 @@ evaluateCaseText :: CaseMeta -> Text -> (CaseMeta, Outcome, String) evaluateCaseText meta source =   let exts = caseExtensions meta-      source' =-        resultOutput-          ( preprocessForParserWithoutIncludesIfEnabled-              (caseExtensions meta)-              []-              (casePath meta)-              []-              source-          )+      source' = preprocessCaseSource meta source       oracleOk = either Just (const Nothing) (oracleModuleAstFingerprint (casePath meta) Syntax.Haskell2010Edition exts source')       validationOk = fmap show (validateParser (casePath meta) Syntax.Haskell2010Edition exts source')    in finalizeOutcome meta oracleOk validationOk++-- | Run CPP on the source of a case when the case enables it.+preprocessCaseSource :: CaseMeta -> Text -> Text+preprocessCaseSource meta source =+  resultOutput+    ( preprocessForParserWithoutIncludesIfEnabled+        (caseExtensions meta)+        []+        (casePath meta)+        []+        source+    )  trim :: String -> String trim = dropWhile isSpace . dropWhileEnd isSpace

@@ -13,6 +13,9 @@ module Aihc.Parser   ( -- * Parsing modules     parseModule,+    parseModuleWithTrace,+    TraceEntry (..),+    tokenKindWithoutSpacing,      -- * Configuration     ParserConfig (..),@@ -38,6 +41,7 @@ import Aihc.Parser.Internal.Module (moduleParser) import Aihc.Parser.Internal.Pattern (patternParser) import Aihc.Parser.Internal.Type (typeParser, typeSignatureParser)+import Aihc.Parser.Lex (LexTokenKind (..)) import Aihc.Parser.Pretty () import Aihc.Parser.Syntax (Decl, Expr, Extension, Module (..), Pattern, SourceSpan, Type, applyImpliedExtensions, sourceSpanEndCol, sourceSpanSourceName, sourceSpanStartCol, sourceSpanStartLine, sourceSpanStartOffset, pattern SourceSpan) import Aihc.Parser.Types@@ -49,6 +53,7 @@ import Data.Word (Word8) import Prettyprinter (Doc, colon, defaultLayoutOptions, layoutPretty, pretty, vcat) import Prettyprinter.Render.String (renderString)+import Text.Megaparsec qualified as MP  -- $setup -- >>> :set -XOverloadedStrings@@ -143,7 +148,47 @@ -- Nothing parseModule :: ParserConfig -> Text -> ([(SourceSpan, Text)], Module) parseModule cfg input =-  case runTokStreamParser parser sourceName (mkTokStreamModule sourceName exts input) of+  let (errs, modu, _) = parseModuleWith id cfg input+   in (errs, modu)++-- | Parse a module and return the token trace with it.+--+-- The trace is each token that the parser took, in order. It contains real+-- tokens and virtual layout tokens, also the virtual close braces that the+-- parser inserts for the parse-error rule. Comments and pragmas are not in+-- the trace. A token that the parser took but did not keep in the AST, for+-- example a trailing comma, has 'traceDiscarded' set.+--+-- Two modules with the same AST have the same trace token kinds when the+-- discarded entries are removed. A formatter can use this to pair the tokens+-- of a source file with the tokens of its pretty-printed form.+parseModuleWithTrace :: ParserConfig -> Text -> ([(SourceSpan, Text)], Module, [TraceEntry])+parseModuleWithTrace = parseModuleWith enableTokStreamTrace++-- | Map a token kind to the kind that it has with spaces around it.+--+-- The lexer gives some operators a different kind when no space separates+-- them from the next or the previous token. For example, @(%1)@ has+-- 'TkPrefixPercent' but @(% 1)@ has @'TkVarSym' "%"@. The text and the AST+-- are the same, so compare trace entries with this function. It also maps+-- the linear arrow @⊸@ to @->@, because the trace of @%1 ->@ keeps only the+-- arrow.+tokenKindWithoutSpacing :: LexTokenKind -> LexTokenKind+tokenKindWithoutSpacing kind =+  case kind of+    TkPrefixMinus -> TkMinusOperator+    TkPrefixBang -> TkVarSym "!"+    TkPrefixTilde -> TkVarSym "~"+    TkPrefixPercent -> TkVarSym "%"+    TkRecordDot -> TkVarSym "."+    TkTypeApp -> TkVarSym "@"+    TkReservedAt -> TkVarSym "@"+    TkLinearArrow -> TkReservedRightArrow+    _ -> kind++parseModuleWith :: (TokStream -> TokStream) -> ParserConfig -> Text -> ([(SourceSpan, Text)], Module, [TraceEntry])+parseModuleWith prepare cfg input =+  case runTokStreamParser parser sourceName (prepare (mkTokStreamModule sourceName exts input)) of     Left bundle ->       ( parseErrorBundleToSpannedText sourceName errorStream bundle,         Module@@ -152,10 +197,11 @@             moduleLanguagePragmas = [],             moduleImports = [],             moduleDecls = []-          }+          },+        []       )-    Right (errs, modu) ->-      (parseErrorsToSpannedText sourceName errorStream errs, modu)+    Right (errs, modu, trace) ->+      (parseErrorsToSpannedText sourceName errorStream errs, modu, trace)   where     sourceName = parserSourceName cfg     exts = applyImpliedExtensions (parserExtensions cfg)@@ -163,7 +209,8 @@     parser = do       modu <- moduleParser       errs <- drainParseErrors-      pure (errs, modu)+      ts <- MP.getInput+      pure (errs, modu, maybe [] (reverse . traceEntries) (tokStreamTrace ts))  -- | 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

@@ -10,27 +10,37 @@ -- \"parse as expression, then reclassify\" strategy described in -- @docs\/unified-expr-pattern-parsing.md@. ----- The core function 'checkPattern' performs a structural recursion over+-- The core function 'checkPatternWith' performs a structural recursion over -- 'Expr', converting each expression node into its pattern counterpart. -- Expression-only constructs (if, case, do, lambda, etc.) are rejected -- with a descriptive error message. module Aihc.Parser.Internal.CheckPattern   ( checkPattern,-    checkPatterns,+    checkPatternWith,   ) where -import Aihc.Parser.Internal.Common (isConLikeName, nameToUnqualified)+import Aihc.Parser.Internal.Common (TokParser, isConLikeName, isExtensionEnabled, liftCheck, nameToUnqualified) import Aihc.Parser.Syntax import Data.Maybe (isJust, isNothing) import Data.Text (Text) +-- | Convert an expression tree into a pattern in the parser.+-- The parser fails with a diagnostic message if the expression cannot be+-- interpreted as a valid pattern.  The enabled extensions control which+-- patterns are valid.+checkPattern :: Expr -> TokParser Pattern+checkPattern expr = do+  nPlusK <- isExtensionEnabled NPlusKPatterns+  liftCheck (checkPatternWith nPlusK expr)+ -- | Convert an expression tree into a pattern.+-- The 'Bool' argument is 'True' when the @NPlusKPatterns@ extension is on. -- Returns @Left@ with a diagnostic message if the expression cannot be -- interpreted as a valid pattern.-checkPattern :: Expr -> Either Text Pattern-checkPattern expr = case expr of-  EAnn ann sub -> fmap (PAnn ann) (checkPattern sub)+checkPatternWith :: Bool -> Expr -> Either Text Pattern+checkPatternWith nPlusK expr = case expr of+  EAnn ann sub -> fmap (PAnn ann) (checkPattern' sub)   EPragma pragma _ -> checkPragmaPattern pragma   -- Variables and constructors   EVar name@@ -45,39 +55,42 @@   -- produce @PParen (PView f pat)@ to preserve the explicit parens in   -- the AST, matching the shape produced by the dedicated pattern parser.   EParen inner-    | Just vp <- asViewPat inner -> Right (PParen vp)-    | otherwise -> PParen <$> checkPattern inner+    | Just vp <- asViewPat nPlusK inner -> Right (PParen vp)+    | otherwise -> PParen <$> checkPattern' inner   -- Tuple   ETuple fl elems     | Just tupleCon <- tupleConstructorPattern fl elems -> Right tupleCon     | otherwise -> do-        pats <- traverse checkTupleElement elems+        pats <- traverse (checkTupleElement nPlusK) elems         Right (PTuple fl pats)   -- List-  EList elems -> PList <$> traverse checkPattern elems+  EList elems -> PList <$> traverse checkPattern' elems   -- Unboxed sum-  EUnboxedSum i n e -> PUnboxedSum i n <$> checkPattern e+  EUnboxedSum i n e -> PUnboxedSum i n <$> checkPattern' e   -- View pattern: @expr -> pat@.   EViewPat l r -> do-    rPat <- checkPattern r+    rPat <- checkPattern' r     Right (PView l rPat)   -- Infix: only constructor operators (starting with ':') are valid in patterns.   EInfix l op r     | isConLikeOp op -> do-        lPat <- checkPattern l-        rPat <- checkPattern r+        lPat <- checkPattern' l+        rPat <- checkPattern' r         Right (PInfix lPat op rPat)+    | nPlusK,+      Just pat <- nPlusKPattern l op r ->+        Right pat     | otherwise -> Left ("unexpected variable operator '" <> renderName op <> "' in pattern")   -- Type signature   ETypeSig e ty -> do-    pat <- checkPattern e+    pat <- checkPattern' e     Right (PTypeSig pat ty)   -- Negation (must be a literal)   ENegate inner -> checkNegLitPattern inner   -- Application: accumulate arguments into PCon   EApp f x -> do-    fPat <- checkPattern f-    xPat <- checkPattern x+    fPat <- checkPattern' f+    xPat <- checkPattern' x     case peelPatternAnn fPat of       PCon name typeArgs args -> Right (PCon name typeArgs (args ++ [xPat]))       PBuiltinCon con typeArgs args -> Right (PBuiltinCon con typeArgs (args ++ [xPat]))@@ -87,7 +100,7 @@     patFields <-       traverse         ( \field -> do-            pat <- checkPattern (recordFieldValue field)+            pat <- checkPattern' (recordFieldValue field)             pure field {recordFieldValue = pat}         )         fields@@ -122,7 +135,7 @@   EGetField {} -> Left "unexpected record field access in pattern"   EGetFieldProjection {} -> Left "unexpected projection section in pattern"   ETypeApp fun ty -> do-    funPat <- checkPattern fun+    funPat <- checkPattern' fun     case peelPatternAnn funPat of       PCon name typeArgs args -> Right (PCon name (typeArgs ++ [ty]) args)       PBuiltinCon con typeArgs args -> Right (PBuiltinCon con (typeArgs ++ [ty]) args)@@ -136,6 +149,8 @@   ETHTypeNameQuote {} -> Left "unexpected Template Haskell type name quote in pattern"   ETHTypedSplice {} -> Left "unexpected typed Template Haskell splice in pattern"   EProc {} -> Left "unexpected proc expression in pattern"+  where+    checkPattern' = checkPatternWith nPlusK  checkPragmaPattern :: Pragma -> Either Text Pattern checkPragmaPattern pragma =@@ -143,14 +158,10 @@     PragmaSCC {} -> Left "unexpected SCC pragma in pattern"     _ -> Left "unexpected pragma in pattern" --- | Convert a list of expressions into patterns.-checkPatterns :: [Expr] -> Either Text [Pattern]-checkPatterns = traverse checkPattern- -- | Check that a tuple element is not a tuple section (Nothing).-checkTupleElement :: Maybe Expr -> Either Text Pattern-checkTupleElement Nothing = Left "unexpected tuple section in pattern"-checkTupleElement (Just e) = checkPattern e+checkTupleElement :: Bool -> Maybe Expr -> Either Text Pattern+checkTupleElement _ Nothing = Left "unexpected tuple section in pattern"+checkTupleElement nPlusK (Just e) = checkPatternWith nPlusK e  -- | A tuple section with no fields, such as @(,)@ or @(#,,#)@, is the -- prefix tuple constructor.@@ -168,6 +179,34 @@   EAnn ann sub -> fmap (PAnn ann) (checkNegLitPattern sub)   _ -> Left "negation in pattern requires a numeric literal" +-- | Try to interpret @l op r@ as an n+k pattern such as @n+1@.+-- The operator must be an unqualified @+@, the left operand must be an+-- unqualified variable, and the right operand must be a plain integer literal.+nPlusKPattern :: Expr -> Name -> Expr -> Maybe Pattern+nPlusKPattern l op r+  | isNothing (nameQualifier op),+    nameType op == NameVarSym,+    nameText op == "+",+    Just var <- nPlusKVar l,+    Just lit <- nPlusKLiteral r =+      Just (PNPlusK var lit)+  | otherwise = Nothing+  where+    nPlusKVar e =+      case e of+        EAnn _ sub -> nPlusKVar sub+        EVar name+          | isNothing (nameQualifier name),+            nameType name == NameVarId,+            nameText name /= "_" ->+              Just (nameToUnqualified name)+        _ -> Nothing+    nPlusKLiteral e =+      case e of+        EAnn ann sub -> LitAnn ann <$> nPlusKLiteral sub+        EInt n TInteger repr -> Just (LitInt n TInteger repr)+        _ -> Nothing+ -- | Check whether an operator is a constructor operator (starts with ':'). -- Constructor operators and backtick-quoted constructors are valid in patterns; -- variable operators like @+@ or @*@ are not.@@ -180,9 +219,9 @@ -- 'checkPattern' to strip the outer parentheses and produce @PView@ -- directly (matching the AST shape that the dedicated pattern parser -- produces).-asViewPat :: Expr -> Maybe Pattern-asViewPat (EViewPat l r) =-  case checkPattern r of+asViewPat :: Bool -> Expr -> Maybe Pattern+asViewPat nPlusK (EViewPat l r) =+  case checkPatternWith nPlusK r of     Right rPat -> Just (PView l rPat)     Left _ -> Nothing-asViewPat _ = Nothing+asViewPat _ _ = Nothing

@@ -176,7 +176,7 @@   expr <- exprParser   hasArrow <- optionalTok TkReservedLeftArrow   if hasArrow-    then DoBind <$> liftCheck (checkPattern expr) <*> cmdParser+    then DoBind <$> checkPattern expr <*> cmdParser     else do       -- No bind arrow: this is a body statement.  Check for arrow tail.       mArrTail <- MP.optional cmdArrTailParser

@@ -12,6 +12,13 @@     tokenKindDispatch,     optionalTok,     optionalTokThen,+    discardTok,+    discardLastToken,+    discardIfEmpty,+    discarding,+    tracePosition,+    discardTraceEntryAt,+    sepEndByDiscard,     eofTok,     varIdTok,     tokenSatisfy,@@ -88,12 +95,12 @@  import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), TokenOrigin (..), closeImplicitLayoutContext) import Aihc.Parser.Syntax-import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, sourcePosSpan, tokStreamExtensionSet)-import Control.Monad (guard)+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), Trace (..), discardLastTraceEntry, discardTraceEntriesFrom, discardTraceRange, mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, sourcePosSpan, tokStreamExtensionSet)+import Control.Monad (guard, unless, when) import Data.Char (isUpper) import Data.Functor (($>)) import Data.List.NonEmpty qualified as NE-import Data.Maybe (catMaybes)+import Data.Maybe (isJust, maybeToList) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T@@ -240,6 +247,66 @@       else pure Nothing {-# INLINE optionalTokThen #-} +-- | Mark the token that the parser took last as discarded in the token trace.+-- Use it for a token that the AST does not keep, for example a trailing comma.+-- Two inputs with the same AST then have the same trace without the discarded+-- tokens.+discardLastToken :: TokParser ()+discardLastToken =+  MP.updateParserState (\s -> s {MP.stateInput = discardLastTraceEntry (MP.stateInput s)})++-- | Run a parser. If its result is empty, mark each token that it took as+-- discarded in the token trace. Use it for an optional clause that the AST+-- does not keep when it is empty, for example @where {}@.+discardIfEmpty :: TokParser [a] -> TokParser [a]+discardIfEmpty parser = do+  start <- traceLengthNow+  items <- parser+  when (null items) $+    MP.updateParserState (\s -> s {MP.stateInput = discardTraceEntriesFrom start (MP.stateInput s)})+  pure items++-- | Run a parser, and mark each token that it took as discarded in the token+-- trace.+discarding :: TokParser a -> TokParser a+discarding parser = do+  start <- traceLengthNow+  result <- parser+  MP.updateParserState (\s -> s {MP.stateInput = discardTraceEntriesFrom start (MP.stateInput s)})+  pure result++traceLengthNow :: TokParser Int+traceLengthNow = maybe 0 traceLength . tokStreamTrace <$> MP.getInput++-- | The position in the token trace of the next token that the parser takes.+tracePosition :: TokParser Int+tracePosition = traceLengthNow++-- | Mark the trace entry at a position from 'tracePosition' as discarded.+discardTraceEntryAt :: Int -> TokParser ()+discardTraceEntryAt position =+  MP.updateParserState (\s -> s {MP.stateInput = discardTraceRange position (position + 1) (MP.stateInput s)})++-- | Take a token of the given kind that the AST does not keep.+discardTok :: LexTokenKind -> TokParser ()+discardTok expected = expectedTok expected *> discardLastToken++-- | Like 'MP.sepEndBy'. The AST does not keep a trailing separator, so the+-- token trace marks it as discarded.+sepEndByDiscard :: TokParser a -> TokParser sep -> TokParser [a]+sepEndByDiscard p sep = sepEndBy1Discard p sep <|> pure []++sepEndBy1Discard :: TokParser a -> TokParser sep -> TokParser [a]+sepEndBy1Discard p sep = do+  x <- p+  rest <- MP.option [] $ do+    _ <- sep+    xs <- sepEndByDiscard p sep+    -- An empty tail takes no token, so the separator is the newest entry.+    when (null xs) discardLastToken+    pure xs+  pure (x : rest)+ -- | Match the end-of-file token. -- -- The lexer emits a 'TkEOF' token at the end of input. This parser consumes@@ -665,7 +732,7 @@     if closed then expectedTok TkSpecialRBrace else MP.empty  skipSemicolons :: TokParser ()-skipSemicolons = MP.skipMany (expectedTok TkSpecialSemicolon)+skipSemicolons = MP.skipMany (discardTok TkSpecialSemicolon)  bracedSemiSep :: TokParser a -> TokParser [a] bracedSemiSep = braces . layoutSemiSep@@ -681,9 +748,33 @@ plainSemiSep1 :: TokParser a -> TokParser [a] plainSemiSep1 = layoutSemiSep1 +-- | Parse items separated by semicolons. An item can be empty.+--+-- The AST keeps only the items. Thus the token trace keeps a semicolon only+-- if an item comes before it and an item follows it directly. Each other+-- semicolon is marked as discarded. Then a list of @n@ items always keeps+-- @n - 1@ semicolons. layoutSemiSep :: TokParser a -> TokParser [a]-layoutSemiSep parser =-  catMaybes <$> MP.sepBy (MP.optional parser) (expectedTok TkSpecialSemicolon)+layoutSemiSep parser = do+  first <- MP.optional parser+  go (isJust first) (maybeToList first)+  where+    go seenItem acc = do+      -- 'MP.optional' adds the semicolon to the expected tokens of an error,+      -- as 'MP.sepBy' did.+      hasSemicolon <- isJust <$> MP.optional (expectedTok TkSpecialSemicolon)+      if not hasSemicolon+        then pure (reverse acc)+        else do+          unless seenItem discardLastToken+          next <- MP.optional parser+          case next of+            Nothing -> do+              -- An empty item takes no token, so the semicolon is the newest+              -- entry.+              when seenItem discardLastToken+              go seenItem acc+            Just item -> go True (item : acc)  layoutSemiSep1 :: TokParser a -> TokParser [a] layoutSemiSep1 parser = do@@ -855,7 +946,7 @@   MP.try parenthesizedContextItemsParser <|> fmap pure (contextItemParserWith typeParser typeAtomParser)   where     parenthesizedContextItemsParser = withSpanAnn annotateSingleItem $ do-      items <- parens (listContextItemParser `MP.sepEndBy` expectedTok TkSpecialComma)+      items <- parens (listContextItemParser `sepEndByDiscard` expectedTok TkSpecialComma)       guardNotFollowedByConstraintInfixOp       case items of         [] -> fail "empty constraint list in parens"@@ -1026,8 +1117,21 @@       rhsPat <- infixPatternParser       expectedTok TkSpecialRParen       tailPats <- MP.many prefixPatternParser+      -- GHC reads a parenthesized infix head with no more arguments as a+      -- pattern.  Thus, with n+k patterns on, @(n + 1) = e@ and+      -- @(n + 1 : xs) = e@ are pattern bindings, not definitions of @(+)@.+      nPlusK <- isExtensionEnabled NPlusKPatterns+      when (nPlusK && null tailPats && isNPlusKHead lhsPat op) $+        fail "an n+k pattern binding is not a function head"       pure (MatchHeadInfix, op, [lhsPat, rhsPat] <> tailPats) +    isNPlusKHead lhsPat op =+      unqualifiedNameType op == NameVarSym+        && unqualifiedNameText op == "+"+        && case peelPatternAnn lhsPat of+          PVar var -> unqualifiedNameType var == NameVarId+          _ -> False+ functionBinderNameParser :: TokParser UnqualifiedName functionBinderNameParser =   variableIdentifierParser <|> parens variableOperatorParser@@ -1117,7 +1221,8 @@       if not hasDotDot         then pure (fields, False)         else do-          _ <- optionalTok TkSpecialComma+          hasComma <- optionalTok TkSpecialComma+          when hasComma discardLastToken           pure (fields, True)     else pure (fields, False) @@ -1160,7 +1265,10 @@   x <- p   rest <- MP.option [] $ do     _ <- layoutSep sep-    layoutSepEndBy p sep+    xs <- layoutSepEndBy p sep+    -- An empty tail takes no token, so the separator is the newest entry.+    when (null xs) discardLastToken+    pure xs   pure (x : rest)  -- | Like Megaparsec's 'MP.sepBy1' but implements the parse-error rule for

@@ -103,6 +103,13 @@         TkReservedDoubleColon -> sigOrValueDecl         TkSpecialComma -> sigOrValueDecl         TkReservedEquals -> valueDecl+        TkVarSym "+" -> do+          -- With n+k patterns on, @n + 1 :: Int = e@ is a typed pattern+          -- binding.  Other declarations here are definitions of @(+)@.+          nPlusK <- isExtensionEnabled NPlusKPatterns+          if nPlusK+            then nonBareVarPatternBindDeclParser <|> valueDecl+            else valueDecl         _           | patternBindMayFollowVarId nextTokKind ->               nonBareVarPatternBindDeclParser <|> valueDecl@@ -139,9 +146,22 @@   pat <- region "while parsing pattern binding" patternParser   case pat of     PVar {} -> fail "bare variable bindings are parsed as function declarations"+    _+      | startsWithNPlusK pat ->+          fail "a binding that starts with n + k without a type signature defines (+)"     _ -> do       DeclValue . PatternBind NoMultiplicityTag pat <$> equationRhsParser +-- | Whether a pattern starts with an n+k pattern and has no type signature.+-- GHC reads @n + 1 = e@ and @n + 1 : xs = e@ as definitions of @(+)@.+startsWithNPlusK :: Pattern -> Bool+startsWithNPlusK pat =+  case pat of+    PAnn _ sub -> startsWithNPlusK sub+    PNPlusK {} -> True+    PInfix lhs _ _ -> startsWithNPlusK lhs+    _ -> False+ -- | Parse a pragma declaration (e.g. {-# INLINE f #-}, {-# SPECIALIZE ... #-}) pragmaDeclParser :: TokParser Decl pragmaDeclParser = withSpanAnn (DeclAnn . mkSpanAnnotation) $ DeclPragma <$> anyPragmaParser "pragma declaration"@@ -594,7 +614,8 @@ classDefaultTypeInstParser' :: Bool -> TokParser ClassDeclItem classDefaultTypeInstParser' requireInstance = withSpanAnn (ClassItemAnn . mkSpanAnnotation) $ do   expectedTok TkKeywordType-  when requireInstance (expectedTok TkKeywordInstance)+  -- The AST does not keep the @instance@ keyword of a default instance.+  when requireInstance (discardTok TkKeywordInstance)   forallBinders <- MP.option [] explicitForallParser   (headForm, lhs) <- typeFamilyLhsParser   expectedTok TkReservedEquals@@ -618,7 +639,8 @@ instanceTypeFamilyInstParser :: TokParser InstanceDeclItem instanceTypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkSpanAnnotation) $ do   expectedTok TkKeywordType-  _ <- optionalTok TkKeywordInstance+  hasInstance <- optionalTok TkKeywordInstance+  when hasInstance discardLastToken   forallBinders <- MP.option [] explicitForallParser   (headForm, lhs) <- typeFamilyLhsParser   expectedTok TkReservedEquals@@ -637,7 +659,8 @@ instanceDataFamilyInstParser :: TokParser InstanceDeclItem instanceDataFamilyInstParser = withSpanAnn (InstanceItemAnn . mkSpanAnnotation) $ do   expectedTok TkKeywordData-  _ <- optionalTok TkKeywordInstance+  hasInstance <- optionalTok TkKeywordInstance+  when hasInstance discardLastToken   (_, head') <- typeFamilyLhsParser   kind <- familyResultKindParser   (constructors, derivingClauses) <- gadtDataDeclParser <|> traditionalDataDeclParser@@ -657,7 +680,8 @@ instanceNewtypeFamilyInstParser :: TokParser InstanceDeclItem instanceNewtypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkSpanAnnotation) $ do   expectedTok TkKeywordNewtype-  _ <- optionalTok TkKeywordInstance+  hasInstance <- optionalTok TkKeywordInstance+  when hasInstance discardLastToken   (_, head') <- typeFamilyLhsParser   kind <- familyResultKindParser   expectedTok TkReservedEquals@@ -712,7 +736,7 @@ defaultDeclParser :: TokParser Decl defaultDeclParser = withSpanAnn (DeclAnn . mkSpanAnnotation) $ do   expectedTok TkKeywordDefault-  DeclDefault <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma)+  DeclDefault <$> parens (typeParser `sepEndByDiscard` expectedTok TkSpecialComma)  -- | Report core general declaration: --@@ -802,15 +826,17 @@         functionalDependencyDetermined = determines       } +-- An empty @where@ clause is not in the AST, so its tokens are discarded. classWhereClauseParser :: TokParser [ClassDeclItem]-classWhereClauseParser = do+classWhereClauseParser = discardIfEmpty $ do   expectedTok TkKeywordWhere   bracedSemiSep classDeclItemParser     <|> plainSemiSep1 classDeclItemParser     <|> pure [] +-- An empty @where@ clause is not in the AST, so its tokens are discarded. whereClauseItemsParser :: TokParser a -> TokParser [a]-whereClauseItemsParser itemParser = do+whereClauseItemsParser itemParser = discardIfEmpty $ do   expectedTok TkKeywordWhere   bracedSemiSep itemParser <|> plainSemiSep1 itemParser <|> pure [] @@ -898,8 +924,9 @@           standaloneDerivingHead = derivingHead         } +-- An empty @where@ clause is not in the AST, so its tokens are discarded. instanceWhereClauseParser :: TokParser [InstanceDeclItem]-instanceWhereClauseParser = do+instanceWhereClauseParser = discardIfEmpty $ do   expectedTok TkKeywordWhere   bracedSemiSep instanceDeclItemParser     <|> plainSemiSep1 instanceDeclItemParser@@ -1358,20 +1385,27 @@       rhs <- declTypeParamParser       pure (InfixBinderHead lhs op rhs []) +    -- The AST keeps these parentheses only when more parameters follow.     parenthesizedInfixDeclHeadParser = do+      openPosition <- tracePosition       expectedTok TkSpecialLParen       lhs <- declTypeParamParser       op <- opParser       rhs <- declTypeParamParser+      closePosition <- tracePosition       expectedTok TkSpecialRParen       tailParams <- MP.many declTypeParamParser+      when (null tailParams) $ do+        discardTraceEntryAt openPosition+        discardTraceEntryAt closePosition       pure (InfixBinderHead lhs op rhs tailParams) +    -- The AST does not keep these parentheses.     parenthesizedPrefixDeclHeadParser = do-      expectedTok TkSpecialLParen+      discardTok TkSpecialLParen       name <- constructorUnqualifiedNameParser       params <- MP.some declTypeParamParser-      expectedTok TkSpecialRParen+      discardTok TkSpecialRParen       tailParams <- MP.many declTypeParamParser       pure (PrefixBinderHead name (params <> tailParams)) @@ -1513,7 +1547,7 @@     _ -> pure (DerivingClause (viaStrategy <|> strategy) classes)   where     singleClass = Left <$> constructorNameParser-    parenClasses = Right <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma)+    parenClasses = Right <$> parens (typeParser `sepEndByDiscard` expectedTok TkSpecialComma)  derivingViaTypeParser :: TokParser Type derivingViaTypeParser = do@@ -1603,7 +1637,7 @@       pure name  recordFieldsParser :: TokParser [FieldDecl]-recordFieldsParser = braces (recordFieldDeclParser `MP.sepEndBy` expectedTok TkSpecialComma)+recordFieldsParser = braces (recordFieldDeclParser `sepEndByDiscard` expectedTok TkSpecialComma)  recordFieldDeclParser :: TokParser FieldDecl recordFieldDeclParser = withSpan $ do@@ -1766,7 +1800,7 @@  -- | Parse the record fields of a pattern synonym: @{field1, field2, ...}@ patSynRecordFieldsParser :: TokParser [Text]-patSynRecordFieldsParser = braces (lowerIdentifierParser `MP.sepEndBy` expectedTok TkSpecialComma)+patSynRecordFieldsParser = braces (lowerIdentifierParser `sepEndByDiscard` expectedTok TkSpecialComma)  -- | Parse the direction marker and RHS pattern of a pattern synonym. patSynDirAndPatParser :: UnqualifiedName -> TokParser (PatSynDir, Pattern)

@@ -17,7 +17,7 @@ import Aihc.Parser.Internal.Cmd (cmdParser) import Aihc.Parser.Internal.Common import Aihc.Parser.Internal.Decl (declParser, fixityDeclParser, pragmaDeclParser)-import Aihc.Parser.Internal.Pattern (apatParser, caseAltPatternParser, patParser, patternParser)+import Aihc.Parser.Internal.Pattern (apatParser, caseAltPatternParser, nPlusKOrPatParser, patParser, patternParser) import Aihc.Parser.Internal.Type (typeAtomParser, typeParser, typeSignatureParser) import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax@@ -61,7 +61,7 @@         _ -> pure ()       hasArrow <- optionalTok TkReservedLeftArrow       if hasArrow-        then Left <$> liftCheck (checkPattern expr)+        then Left <$> checkPattern expr         else pure (Right expr)      patternBind = do@@ -1433,7 +1433,7 @@ thTypeQuoteParser = thQuoteParser (EAnn . mkSpanAnnotation) TkTHTypeQuoteOpen TkTHExpQuoteClose typeParser ETHTypeQuote  thPatQuoteParser :: TokParser Expr-thPatQuoteParser = thQuoteParser (EAnn . mkSpanAnnotation) TkTHPatQuoteOpen TkTHExpQuoteClose patParser ETHPatQuote+thPatQuoteParser = thQuoteParser (EAnn . mkSpanAnnotation) TkTHPatQuoteOpen TkTHExpQuoteClose nPlusKOrPatParser ETHPatQuote  thUntypedSpliceParser :: TokParser Expr thUntypedSpliceParser = withSpanAnn (EAnn . mkSpanAnnotation) $ do

@@ -51,7 +51,7 @@     _ -> Nothing  exportSpecListParser :: TokParser [ExportSpec]-exportSpecListParser = parens $ exportSpecParser `MP.sepEndBy` expectedTok TkSpecialComma+exportSpecListParser = parens $ exportSpecParser `sepEndByDiscard` expectedTok TkSpecialComma  exportSpecParser :: TokParser ExportSpec exportSpecParser = withSpanAnn (ExportAnn . mkSpanAnnotation) $ do@@ -102,6 +102,8 @@         False -> pure MembersAll         True -> do           trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma+          -- With no member after it, the comma is not in the AST.+          when (null trailingMembers) discardLastToken           pure (MembersListAll 0 trailingMembers)      parseMemberList = do@@ -122,6 +124,8 @@         False -> pure (MembersListAll (length members) members)         True -> do           trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma+          -- With no member after it, the comma is not in the AST.+          when (null trailingMembers) discardLastToken           pure (MembersListAll (length members) (members <> trailingMembers))      memberNameParser = do@@ -192,7 +196,7 @@ importSpecParser = withSpan $ do   isHiding <-     MP.option False (expectedTok TkVarHiding >> pure True)-  items <- parens $ importItemParser `MP.sepEndBy` expectedTok TkSpecialComma+  items <- parens $ importItemParser `sepEndByDiscard` expectedTok TkSpecialComma   pure $ \span' ->     ImportSpec       { importSpecAnns = [mkSpanAnnotation span'],

@@ -24,7 +24,9 @@ import Aihc.Parser.Internal.Import (importDeclParser, languagePragmaParser, moduleHeaderParser) import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind) import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mkSpanAnnotation)-import Control.Monad (void)+import Aihc.Parser.Types (TokStream (..))+import Control.Monad (void, when)+import Data.Maybe (isJust) import Text.Megaparsec qualified as MP  data RecoverParseStep a@@ -40,8 +42,8 @@   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))+  languagePragmas <- MP.many (languagePragmaParser <* skipSemicolons)+  mHeader <- MP.optional (moduleHeaderParser <* skipSemicolons)   expectedTok TkSpecialLBrace   imports <- importDeclsWithRecovery   (decls, finalState) <-@@ -52,6 +54,11 @@           <* MP.lookAhead eofTok       )   MP.updateParserState (\state -> state {MP.stateParseErrors = MP.stateParseErrors finalState})+  -- The declarations were parsed in a separate run. With a token trace, take+  -- the stream from the end of that run, so the trace has their tokens. This+  -- forces the declarations, so only a traced parse does it.+  when (isJust (tokStreamTrace startInput)) $+    MP.updateParserState (\state -> state {MP.stateInput = MP.stateInput finalState})   let moduleSpan = consumedSpan inputStart startInput startOffset (MP.stateInput finalState) (MP.stateOffset finalState)   pure     Module

@@ -4,6 +4,7 @@   ( patternParser,     patternParserWithTypeSigParser,     caseAltPatternParser,+    nPlusKOrPatParser,     patParser,     lpatParser,     apatParser,@@ -34,7 +35,7 @@     optionalSuffix       (expectedTok TkReservedDoubleColon *> typeSigParser)       PTypeSig-      patParser+      nPlusKOrPatParser  -- | Parse the pattern position of a case alternative. --@@ -46,8 +47,56 @@ -- | Case alternatives intentionally use the report @pat@ level rather than -- the outer typed-pattern wrapper. caseAltPatternParser :: TokParser Pattern-caseAltPatternParser = patParser+caseAltPatternParser = nPlusKOrPatParser +-- | Parse an n+k pattern or a @pat@.+--+-- Haskell 98 puts the n+k pattern at the top pattern level:+--+-- @+-- pat → var + integer+--     | pat0+-- @+--+-- Only accept the n+k form when the @NPlusKPatterns@ extension is on.+-- Function heads do not use this parser.  In a function head, @n + 1 = e@+-- is a definition of @(+)@, not a pattern binding.+--+-- Like GHC, accept an n+k pattern as the left operand of an infix+-- constructor pattern, as in @n + 1 : xs@.+nPlusKOrPatParser :: TokParser Pattern+nPlusKOrPatParser = do+  enabled <- isExtensionEnabled NPlusKPatterns+  isNPlusK <- if enabled then startsNPlusKPattern else pure False+  if isNPlusK+    then do+      lhs <- nPlusKPatternParser+      rest <- MP.many ((,) <$> conOperatorParser <*> lpatParser)+      pure (foldInfixL buildInfixPattern lhs rest)+    else patParser++-- | Look at the next three tokens for @var + integer@.+startsNPlusKPattern :: TokParser Bool+startsNPlusKPattern = do+  tokens <- MP.optional . MP.try . lookAhead $ (,,) <$> anySingle <*> anySingle <*> anySingle+  pure $+    case tokens of+      Just (varTok, plusTok, intTok) ->+        case (lexTokenKind varTok, lexTokenKind plusTok, lexTokenKind intTok) of+          (TkVarId {}, TkVarSym "+", TkInteger _ TInteger) -> True+          _ -> False+      Nothing -> False++nPlusKPatternParser :: TokParser Pattern+nPlusKPatternParser = withSpanAnn (PAnn . mkSpanAnnotation) $ do+  name <-+    tokenSatisfy "variable" $ \tok ->+      case lexTokenKind tok of+        TkVarId ident -> Just (mkUnqualifiedNameAt tok NameVarId ident)+        _ -> Nothing+  expectedTok (TkVarSym "+")+  PNPlusK name <$> intLiteralParser+ -- | Parse a pattern (@pat@ in the Haskell Report). -- -- @@@ -323,7 +372,7 @@ -- | Parse the contents of record pattern braces, supporting RecordWildCards ".." recordPatternFieldListParser :: TokParser ([RecordField Pattern], Bool) recordPatternFieldListParser =-  recordFieldsWithWildcardsParser (recordFieldPatternParser `MP.sepEndBy` expectedTok TkSpecialComma)+  recordFieldsWithWildcardsParser (recordFieldPatternParser `sepEndByDiscard` expectedTok TkSpecialComma)  listPatternParser :: TokParser Pattern listPatternParser = withSpanAnn (PAnn . mkSpanAnnotation) $ do@@ -355,12 +404,12 @@     tok <- peekToken     case lexTokenKind tok of       TkReservedRightArrow -> pure (Left expr)-      TkSpecialComma -> Right <$> liftCheck (checkPattern expr)-      TkSpecialRBracket -> Right <$> liftCheck (checkPattern expr)-      TkSpecialRBrace -> Right <$> liftCheck (checkPattern expr)-      TkSpecialRParen -> Right <$> liftCheck (checkPattern expr)-      TkSpecialUnboxedRParen -> Right <$> liftCheck (checkPattern expr)-      TkReservedPipe -> Right <$> liftCheck (checkPattern expr)+      TkSpecialComma -> Right <$> checkPattern expr+      TkSpecialRBracket -> Right <$> checkPattern expr+      TkSpecialRBrace -> Right <$> checkPattern expr+      TkSpecialRParen -> Right <$> checkPattern expr+      TkSpecialUnboxedRParen -> Right <$> checkPattern expr+      TkReservedPipe -> Right <$> checkPattern expr       _ -> fail "incomplete element parse"   case mResult of     Just (Left expr) -> do

@@ -21,6 +21,7 @@ import {-# SOURCE #-} Aihc.Parser.Internal.Expr (exprParser) import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax+import Control.Monad (when) import Data.Char (isLower) import Data.Functor (($>), (<&>)) import Data.Text qualified as T@@ -199,10 +200,17 @@ -- from @a % 1 -> b@ (type operator applied to @a@ and @1@, then unrestricted arrow). multiplicityAnnotatedArrowParser :: TokParser ArrowKind multiplicityAnnotatedArrowParser = do+  start <- tracePosition   expectedTok TkPrefixPercent   mult <- typeAtomParser+  arrowPosition <- tracePosition   expectedTok TkReservedRightArrow-  pure (multiplicityToArrowKind mult)+  let arrowKind = multiplicityToArrowKind mult+  -- The AST does not tell @%1 ->@ from @⊸@. Keep only the arrow in the+  -- token trace, so both spellings give the same trace.+  when (arrowKind == ArrowLinear) $+    mapM_ discardTraceEntryAt [start .. arrowPosition - 1]+  pure arrowKind  multiplicityToArrowKind :: Type -> ArrowKind multiplicityToArrowKind ty =

@@ -665,7 +665,10 @@       wrapPat         (typedPatternBindLhsNeedsParens inner)         (PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty))-    _ -> addPatternParens pat+    -- A bare @n + 1 = e@ defines @(+)@.  Keep the parentheses so that the+    -- declaration stays a pattern binding.  With a type signature, as in+    -- @n + 1 :: Int = e@, the declaration is always a pattern binding.+    _ -> wrapLeadingNPlusK (addPatternParens pat)  typedPatternBindLhsNeedsParens :: Pattern -> Bool typedPatternBindLhsNeedsParens (PAnn _ sub) = typedPatternBindLhsNeedsParens sub@@ -1399,6 +1402,13 @@   -- following @by@ or @using@ keyword. Parenthesizing it is not only   -- unnecessary: GHC preserves the grouping in its parsed fingerprint.   EIf {} -> False+  -- With TransformListComp, @by@ and @using@ are keywords.  The keyword+  -- closes the implicit layout block of the case alternatives, so a case+  -- expression needs no parentheses here.+  ECase {} -> False+  -- A multi-way if also opens an implicit layout block, and the keyword+  -- closes it.+  EMultiWayIf {} -> False   ETypeSig {} -> True   EParen {} -> False   EInfix _ _ rhs -> needsCompTransformInfixRhsParens rhs@@ -1737,12 +1747,25 @@     PStrict inner -> PStrict (addApatParens inner)     PIrrefutable inner -> PIrrefutable (addApatParens inner)     PNegLit lit -> PNegLit lit+    PNPlusK name lit -> PNPlusK name lit     PParen inner -> PParen (addPatternInDelimited inner)     PRecord con fields hasWildcard ->       PRecord con [field {recordFieldValue = addPatternInRecordField (recordFieldValue field)} | field <- fields] hasWildcard     PTypeSig inner ty -> PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty)     PSplice body -> PSplice (addSpliceBodyParens body) +-- | Put parens around an n+k pattern at the start of a pattern.+-- An n+k pattern can be the left operand of an infix pattern, as in+-- @n + 1 : xs@.  At the start of a declaration, @n + 1@ starts a+-- definition of @(+)@, so the n+k pattern needs parens there.+wrapLeadingNPlusK :: Pattern -> Pattern+wrapLeadingNPlusK pat =+  case pat of+    PAnn ann sub -> PAnn ann (wrapLeadingNPlusK sub)+    PNPlusK {} -> wrapPat True pat+    PInfix lhs op rhs -> PInfix (wrapLeadingNPlusK lhs) op rhs+    _ -> pat+ -- | Add parens for a pattern inside a delimited context (tuples, lists, etc.). -- View patterns don't need extra parens there. addPatternInDelimited :: Pattern -> Pattern@@ -1932,6 +1955,9 @@     PLit {} -> addPatternParens pat     PQuasiQuote {} -> addPatternParens pat     PNegLit {} -> wrapPat True (addPatternParens pat)+    -- An n+k pattern is a top-level pattern form, so each atom position+    -- needs parentheses.+    PNPlusK {} -> wrapPat True (addPatternParens pat)     PList {} -> addPatternParens pat     PTuple {} -> addPatternParens pat     PUnboxedSum {} -> addPatternParens pat@@ -1957,6 +1983,9 @@   case pat of     PAnn ann sub -> PAnn ann (addPatternInfixOperandParens sub)     PNegLit _ -> addPatternParens pat+    -- The left operand of an infix pattern can be an n+k pattern, as in+    -- @n + 1 : xs@.+    PNPlusK {} -> addPatternParens pat     PCon {} -> addPatternParens pat     PBuiltinCon {} -> addPatternParens pat     PInfix {} -> addPatternParens pat@@ -1983,6 +2012,7 @@ addArrowBndrPatternParens :: Pattern -> Pattern addArrowBndrPatternParens p@(PTypeSig {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PNegLit {}) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PNPlusK {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PInfix {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PCon _ (_ : _) _) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PCon _ [] (_ : _)) = wrapPat True (addPatternParens p)@@ -2018,9 +2048,11 @@     -- Infix function heads use infix-pattern operand grammar, where negative     -- literal patterns do not require apat parentheses.     PNegLit {} -> addPatternParens pat+    -- In a function head, @n + 1 `op` x@ does not parse as an n+k operand.+    PNPlusK {} -> wrapPat True (addPatternParens pat)     PAs {} -> addPatternParens pat     PTypeSig {} -> wrapPat True (addPatternParens pat)-    PInfix {} -> addPatternParens pat+    PInfix {} -> wrapLeadingNPlusK (addPatternParens pat)     _ -> addPatternParens pat  -- | Add parens for the inner pattern of @, !, ~.

@@ -40,15 +40,22 @@     align,     braces,     brackets,+    column,     comma,+    concatWith,+    flatAlt,+    group,     hang,     hardline,     hsep,+    line,+    line',     nest,     nesting,     parens,     punctuate,     semi,+    softline,     vsep,     (<+>),   )@@ -61,6 +68,31 @@ -- >>> import Prettyprinter.Render.String (renderString) -- >>> let renderDoc = renderString . layoutPretty defaultLayoutOptions +-- __Line breaks.__ A construct that can fit on one line uses 'group' with+-- soft breaks ('line', 'line'', or 'spacedLine'). If the construct does not+-- fit, each soft break becomes a line break. Layout blocks ('do', 'case',+-- 'let', 'where', guards, and declaration lists) use 'hardline' and+-- 'hardVsep'. A 'group' that contains a hard line break does not become flat.+-- Thus a layout block always stops the enclosing groups from becoming flat,+-- and text that follows a block cannot move into the block.++-- | Put each document on a new line. Unlike 'vsep', the breaks stay line+-- breaks in a 'group'. Use this for layout blocks.+hardVsep :: [Doc ann] -> Doc ann+hardVsep = concatWith (\x y -> x <> hardline <> y)++-- | A soft break that keeps one space before the next token when it breaks.+-- In a flat 'group', it is one space.+spacedLine :: Doc ann+spacedLine = flatAlt (hardline <> " ") " "++-- | An empty document that stops each enclosing 'group' from becoming flat.+-- Use it at the end of a layout block that has no closing token, for example+-- a multi-way @if@. Text on the same line after such a block goes into the+-- block, so the enclosing construct must break the line.+noFlat :: Doc ann+noFlat = flatAlt mempty hardline+ -- | Wrap a document in braces with interior spaces: @{ content }@. -- Unlike 'braces' which produces @{content}@, this version avoids the -- @{-@ block-comment ambiguity that occurs when the content starts with a@@ -70,9 +102,15 @@  prettyRawText :: Text -> Doc ann prettyRawText raw-  | T.isInfixOf "\n" raw = nesting $ \level -> nest (negate level) (pretty raw)+  | T.isInfixOf "\n" raw = nesting $ \level -> nest (negate level) (prettyHardLines raw)   | otherwise = pretty raw +-- | Print text that can contain newlines. Each newline stays a line break in+-- a 'group'. The 'Pretty' instance for 'Text' uses 'line', which a flat+-- 'group' changes to a space.+prettyHardLines :: Text -> Doc ann+prettyHardLines = hardVsep . map pretty . T.splitOn "\n"+ prettySpliceBody :: Expr -> Doc ann prettySpliceBody = prettyExpr @@ -90,7 +128,7 @@  -- | Pretty instance for Decl - renders to valid Haskell source code. instance Pretty Decl where-  pretty decl = vsep (prettyDeclLines (addDeclParens decl))+  pretty decl = hardVsep (prettyDeclLines (addDeclParens decl))  -- | Pretty instance for Type - renders to valid Haskell source code. instance Pretty Type where@@ -104,7 +142,7 @@  prettyModuleDoc :: Module -> Doc ann prettyModuleDoc modu =-  vsep (pragmaLines <> headerLines <> importLines <> declLines)+  hardVsep (pragmaLines <> headerLines <> importLines <> declLines)   where     pragmaLines =       map@@ -126,7 +164,7 @@  prettyExportSpecList :: [ExportSpec] -> Doc ann prettyExportSpecList specs =-  parens (hsep (punctuate comma (map prettyExportSpec specs)))+  parens (prettyCommaFill (map prettyExportSpec specs))  prettyExportSpec :: ExportSpec -> Doc ann prettyExportSpec spec =@@ -193,7 +231,7 @@ prettyImportSpec spec =   hsep     ( ["hiding" | importSpecHiding spec]-        <> [parens (hsep (punctuate comma (map prettyImportItem (importSpecItems spec))))]+        <> [parens (prettyCommaFill (map prettyImportItem (importSpecItems spec)))]     )  prettyImportItem :: ImportItem -> Doc ann@@ -392,7 +430,7 @@ prettyPatSynWhere _ PatSynUnidirectional = [] prettyPatSynWhere _ (PatSynExplicitBidirectional []) = ["where", spacedBraces mempty] prettyPatSynWhere name (PatSynExplicitBidirectional matches) =-  ["where" <> nest 2 (hardline <> vsep (map (prettyFunctionMatch name) matches))]+  ["where" <> nest 2 (hardline <> hardVsep (map (prettyFunctionMatch name) matches))]  prettyFunctionMatchLines :: UnqualifiedName -> Match -> [Doc ann] prettyFunctionMatchLines name match =@@ -403,7 +441,7 @@           <> nest             2             ( hardline-                <> vsep+                <> hardVsep                   ( map prettyGuardedRhsBlock grhss                       <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls]                   )@@ -443,7 +481,7 @@ prettyWhereClauseBare Nothing = mempty prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty prettyWhereClauseBare (Just decls) =-  "where" <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls))+  "where" <> nest 2 (hardline <> hardVsep (concatMap prettyDeclLines decls))  prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann prettyIndentedWhereClause Nothing = mempty@@ -453,7 +491,7 @@ prettyTHDeclQuote [] = "[d| |]" prettyTHDeclQuote decls =   "[d|"-    <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls))+    <> nest 2 (hardline <> hardVsep (concatMap prettyDeclLines decls))     <+> "|]"  -- | Infix type-family heads use @l \`Op\` r@ with a 'NameConId' operator (e.g.@@ -521,7 +559,9 @@     TTypeApp f x ->       prettyType f <+> prettyTypeAppArg x     TFun arrowKind a b ->-      prettyType a <+> prettyArrowKind arrowKind <+> prettyType b+      -- When the arrows do not fit, each argument after the first starts a+      -- new line with its arrow.+      group (prettyType a <> nest 2 (prettyArrowTail arrowKind b))     TTuple tupleFlavor promoted elems ->       let elemsDoc = hsep (punctuate comma (map prettyType elems))           tupleDoc = prettyTupleBody tupleFlavor elemsDoc@@ -543,10 +583,33 @@     TContext constraints inner ->       case constraints of         [] -> prettyType inner-        cs -> prettyContext cs <+> "=>" <+> prettyType inner+        cs -> withContext cs (prettyType inner)     TSplice body -> "$" <> prettySpliceBody body     TWildcard -> "_" +-- | The arrows and arguments of a function type after its first argument.+prettyArrowTail :: ArrowKind -> Type -> Doc ann+prettyArrowTail arrowKind ty =+  line+    <> prettyArrowKind arrowKind+    <+> case ty of+      TAnn _ sub -> continue sub+      _ -> continue ty+  where+    continue t =+      case t of+        TFun nextKind a b -> prettyType a <> prettyArrowTail nextKind b+        TAnn _ sub -> continue sub+        _ -> prettyType t++-- | A context and the item that it applies to. When they do not fit, the+-- item starts a new line after the @=>@.+withContext :: [Type] -> Doc ann -> Doc ann+withContext constraints doc =+  case constraints of+    [] -> doc+    _ -> group (prettyContext constraints <> nest 2 (line <> "=>" <+> doc))+ prettyArrowKind :: ArrowKind -> Doc ann prettyArrowKind ArrowUnrestricted = "->" prettyArrowKind ArrowLinear = "%1" <+> "->"@@ -607,11 +670,12 @@       hsep ([prettyBuiltinCon con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)     PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs     PView viewExpr inner ->-      prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyPattern inner)+      group (prettyExpr viewExpr <> nest 1 (line <> "->" <+> prettyPattern inner))     PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner     PStrict inner -> "!" <> prettyPattern inner     PIrrefutable inner -> "~" <> prettyPattern inner     PNegLit lit -> "-" <> prettyLiteral lit+    PNPlusK name lit -> prettyBinderUName name <+> "+" <+> prettyLiteral lit     PParen inner -> parens (prettyPattern inner)     PRecord con fields hasWildcard ->       prettyPrefixName con@@ -652,7 +716,7 @@       | any isGadtCon ctors ->           headDoc <+> prettyGadtConBlock ctors (dataDeclDeriving decl)     _ ->-      hsep (headParts <> ctorPart <> derivingParts (dataDeclDeriving decl))+      prettyDataBody headDoc (dataDeclConstructors decl) (dataDeclDeriving decl)   where     headParts =       ["data"]@@ -661,17 +725,27 @@         <> kindPart     headDoc = hsep headParts     kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)-    ctorPart =-      case dataDeclConstructors decl of-        [] -> []-        ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))] +-- | The constructors and deriving clauses after a data declaration head. When+-- they do not fit, each constructor and each deriving clause starts a new+-- line.+prettyDataBody :: Doc ann -> [DataConDecl] -> [DerivingClause] -> Doc ann+prettyDataBody headDoc ctors derivingClauses =+  group (headDoc <> nest 2 (ctorDocs <> derivingDocs))+  where+    ctorDocs =+      mconcat+        [ line <> separator <+> prettyDataCon ctor+        | (separator, ctor) <- zip ("=" : repeat "|") ctors+        ]+    derivingDocs = mconcat [line <> hsep (derivingPart clause) | clause <- derivingClauses]+ prettyTypeDataDecl :: DataDecl -> Doc ann prettyTypeDataDecl decl =   case dataDeclConstructors decl of     ctors       | any isGadtCon ctors -> headDoc <+> prettyGadtConBlock ctors []-    _ -> hsep (headParts <> ctorPart)+    _ -> prettyDataBody headDoc (dataDeclConstructors decl) []   where     headParts =       ["type data"]@@ -679,10 +753,6 @@         <> kindPart     headDoc = hsep headParts     kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl)-    ctorPart =-      case dataDeclConstructors decl of-        [] -> []-        ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))]  isGadtCon :: DataConDecl -> Bool isGadtCon (DataConAnn _ inner) = isGadtCon inner@@ -696,7 +766,7 @@       | isGadtCon ctor ->           headDoc <+> prettyGadtConBlock [ctor] (newtypeDeclDeriving decl)     _ ->-      hsep (headParts <> ctorPart <> derivingParts (newtypeDeclDeriving decl))+      prettyDataBody headDoc (maybe [] pure (newtypeDeclConstructor decl)) (newtypeDeclDeriving decl)   where     headParts =       ["newtype"]@@ -705,10 +775,6 @@         <> kindPart     headDoc = hsep headParts     kindPart = maybe [] (\k -> ["::", prettyType k]) (newtypeDeclKind decl)-    ctorPart =-      case newtypeDeclConstructor decl of-        Nothing -> []-        Just ctor -> ["=", prettyDataCon ctor]  derivingParts :: [DerivingClause] -> [Doc ann] derivingParts = concatMap derivingPart@@ -716,7 +782,7 @@ prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann prettyGadtConBlock ctors derivingClauses =   "where"-    <> nest 2 (hardline <> vsep (map prettyDataCon ctors <> derivingParts derivingClauses))+    <> nest 2 (hardline <> hardVsep (map prettyDataCon ctors <> derivingParts derivingClauses))  derivingPart :: DerivingClause -> [Doc ann] derivingPart (DerivingClause strategy classes) =@@ -848,26 +914,31 @@     GadtPrefixBody args resultTy ->       case args of         [] -> prettyType resultTy-        _ ->-          hsep $-            concatMap (\(bt, ak) -> [prettyBangType bt, prettyArrowKind ak]) args-              ++ [prettyType resultTy]+        (firstArg, firstKind) : rest ->+          group+            ( prettyBangType firstArg+                <> nest+                  2+                  ( mconcat+                      [ line <> prettyArrowKind kind <+> doc+                      | (kind, doc) <- zip (firstKind : map snd rest) (map (prettyBangType . fst) rest <> [prettyType resultTy])+                      ]+                  )+            )     GadtRecordBody fields resultTy ->       braces (prettyRecordFields fields) <+> "->" <+> prettyType resultTy  prettyRecordFields :: [FieldDecl] -> Doc ann prettyRecordFields fields =-  hsep-    ( punctuate-        comma-        [ hsep $-            [hsep (punctuate comma (map prettyFieldName (fieldNames fld)))]-              <> maybe [] (\mult -> ["%" <> prettyType mult]) (fieldMultiplicity fld)-              <> [ "::",-                   prettyRecordFieldBangType (fieldType fld)-                 ]-        | fld <- fields-        ]+  prettyCommaBlock+    ( [ hsep $+          [hsep (punctuate comma (map prettyFieldName (fieldNames fld)))]+            <> maybe [] (\mult -> ["%" <> prettyType mult]) (fieldMultiplicity fld)+            <> [ "::",+                 prettyRecordFieldBangType (fieldType fld)+               ]+      | fld <- fields+      ]     )   where     prettyFieldName :: UnqualifiedName -> Doc ann@@ -898,18 +969,17 @@ prettyClassDecl :: ClassDecl -> Doc ann prettyClassDecl decl =   let headDoc =-        hsep-          ( ["class"]-              <> maybeContextPrefix (classDeclContext decl)-              <> prettyNamedBinderHead (classDeclHead decl)-              <> prettyClassFundeps (classDeclFundeps decl)-          )+        let classHead = hsep (prettyNamedBinderHead (classDeclHead decl) <> prettyClassFundeps (classDeclFundeps decl))+         in "class"+              <+> case classDeclContext decl of+                Nothing -> classHead+                Just constraints -> group (prettyContext constraints <> nest 2 (line <> "=>" <+> classHead))    in case classDeclItems decl of         [] -> headDoc         items ->           headDoc             <+> "where"-            <> nest 2 (hardline <> vsep (concatMap prettyClassItemLines items))+            <> nest 2 (hardline <> hardVsep (concatMap prettyClassItemLines items))  prettyClassFundeps :: [FunctionalDependency] -> [Doc ann] prettyClassFundeps deps =@@ -933,12 +1003,6 @@       hsep (map pretty (typeFamilyInjectivityDetermined injectivity))     ] -maybeContextPrefix :: Maybe [Type] -> [Doc ann]-maybeContextPrefix maybeConstraints =-  case maybeConstraints of-    Nothing -> []-    Just constraints -> [prettyContext constraints, "=>"]- prettyClassItem :: ClassDeclItem -> Doc ann prettyClassItem item =   case item of@@ -973,15 +1037,14 @@               <> map prettyPragma (instanceDeclPragmas decl)               <> maybe [] (\w -> [prettyPragma w]) (instanceDeclWarning decl)               <> forallTyVarBinderPrefix (instanceDeclForall decl)-              <> contextPrefix (instanceDeclContext decl)-              <> [prettyType (instanceDeclHead decl)]+              <> [withContext (instanceDeclContext decl) (prettyType (instanceDeclHead decl))]           )    in case instanceDeclItems decl of         [] -> headDoc         items ->           headDoc             <+> "where"-            <> nest 2 (hardline <> vsep (concatMap prettyInstanceItemLines items))+            <> nest 2 (hardline <> hardVsep (concatMap prettyInstanceItemLines items))  prettyStandaloneDeriving :: StandaloneDerivingDecl -> Doc ann prettyStandaloneDeriving decl =@@ -998,7 +1061,7 @@  prettyPragma :: Pragma -> Doc ann prettyPragma pragma-  | not (T.null (pragmaRawText pragma)) = pretty (pragmaRawText pragma)+  | not (T.null (pragmaRawText pragma)) = prettyHardLines (pragmaRawText pragma)   | otherwise = prettyPragmaType (pragmaType pragma)  prettyPragmaType :: PragmaType -> Doc ann@@ -1020,7 +1083,7 @@         NoUnpackPragma -> "{-# NOUNPACK #-}"     PragmaSource sourceText _ -> "{-# SOURCE " <> pretty sourceText <> " #-}"     PragmaSCC label -> "{-# SCC " <> pretty label <> " #-}"-    PragmaUnknown text -> pretty text+    PragmaUnknown text -> prettyHardLines text  prettyDerivingStrategy :: DerivingStrategy -> Doc ann prettyDerivingStrategy strategy =@@ -1199,13 +1262,13 @@ -- nodes in the correct positions (inserted by 'addExprParens'). -- -- >>> let expr = EApp (EVar "f") (EParen (EInfix (EVar "x") "+" (EVar "y"))) in (renderDoc (prettyExpr expr), show (shorthand expr))--- ("f\n  (x\n   + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))")+-- ("f (x + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))") prettyExpr :: Expr -> Doc ann prettyExpr expr =   case expr of     EApp {} -> prettyApp expr     ETypeApp fn ty ->-      nest 2 (prettyExpr fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty)+      group (nest 2 (prettyExpr fn) <> nest 1 (spacedLine <> prettyTypeAppArg ty))     EVar name -> prettyName name     EImplicitParam name -> pretty name     ETypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty@@ -1228,9 +1291,9 @@     ETHSplice body -> "$" <> prettySpliceBody body     ETHTypedSplice body -> "$$" <> prettySpliceBody body     EIf cond yes no ->-      "if" <+> prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no+      group ("if" <+> prettyExpr cond <> nest 2 (line <> "then" <+> prettyExpr yes <> line <> "else" <+> prettyExpr no))     EMultiWayIf rhss ->-      "if" <+> align (prettyMultiWayIfRhss rhss)+      "if" <> prettyMultiWayIfBlock (prettyMultiWayIfRhss rhss) <> noFlat     ELambdaPats pats body ->       "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyExpr body     ELambdaCase alts ->@@ -1238,17 +1301,17 @@     ELambdaCases alts ->       "\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts)     EInfix lhs op rhs ->-      nest 2 (prettyExpr lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs)+      group (nest 2 (prettyExpr lhs) <> nest 1 (line <> prettyNameInfixOp op <+> prettyExpr rhs))     EViewPat viewExpr rhs ->-      prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyExpr rhs)+      group (prettyExpr viewExpr <> nest 1 (line <> "->" <+> prettyExpr rhs))     ENegate inner -> "-" <+> prettyExprAtStatementStart inner     ESectionL lhs op ->-      nest 2 (prettyExpr lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op)+      group (nest 2 (prettyExpr lhs) <> nest 1 (spacedLine <> prettyNameInfixOp op))     ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs     ELetDecls decls body ->       case decls of         [] -> prettyLetDecls decls <+> "in" <+> prettyExpr body-        _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyExpr body))+        _ -> group (align (prettyLetDecls decls <> nest 2 (line <> "in" <+> prettyExpr body)))     ECase scrutinee alts ->       prettyCaseExpr prettyCaseLayout scrutinee alts     EDo stmts flavor ->@@ -1256,28 +1319,28 @@     EListComp body quals ->       brackets         ( let qualifiers = prettyCommaSeparated prettyCompStmt quals-           in prettyExpr body <> hardline <> " |" <+> qualifiers+           in group (prettyExpr body <> spacedLine <> "|" <+> qualifiers)         )     EListCompParallel body qualifierGroups ->       brackets         ( let qualifiers =                 prettyBarSeparated-                  [ prettyCommaSeparated prettyCompStmt group-                  | group <- qualifierGroups+                  [ prettyCommaSeparated prettyCompStmt qualifierGroup+                  | qualifierGroup <- qualifierGroups                   ]-           in prettyExpr body <> hardline <> " |" <+> qualifiers+           in group (prettyExpr body <> spacedLine <> "|" <+> qualifiers)         )     EArithSeq seqInfo -> prettyArithSeq seqInfo     ERecordCon name fields hasWildcard ->-      prettyPrefixName name <+> braces (hsep (punctuate comma (map prettyBinding fields ++ [".." | hasWildcard])))+      prettyPrefixName name <+> braces (prettyCommaBlock (map prettyBinding fields ++ [".." | hasWildcard]))     ERecordUpd base fields ->-      prettyExpr base <+> braces (hsep (punctuate comma (map prettyBinding fields)))+      prettyExpr base <+> braces (prettyCommaBlock (map prettyBinding fields))     EGetField base field ->       prettyExpr base <> "." <> prettyName field     EGetFieldProjection fields ->       "." <> mconcat (punctuate "." (map prettyName fields))     ETypeSig inner ty ->-      nest 2 (prettyExpr inner) <> nest 1 (hardline <> "::" <+> prettyType ty)+      group (nest 2 (prettyExpr inner) <> nest 1 (line <> "::" <+> prettyType ty))     EParen inner -> case inner of       ECase scrutinee alts ->         parens (prettyCaseExpr prettyCaseLayout scrutinee alts)@@ -1309,24 +1372,59 @@ prettyAppWith :: (Expr -> Doc ann) -> Expr -> Doc ann prettyAppWith prettyFn expr =   let (fn, args) = flattenApps expr-   in prettyFn fn <> nest 2 (hardline <> vsep (map prettyExpr args))+   in prettyFn fn <> nest 2 (softline <> fillArguments args)   where+    -- Put as many arguments on a line as fit. After an argument that ends+    -- with a layout block, start a new line: text on the same line goes into+    -- the block.+    fillArguments [] = mempty+    fillArguments [arg] = prettyExpr arg+    fillArguments (arg : rest) =+      prettyExpr arg <> (if endsWithLayoutBlock arg then hardline else softline) <> fillArguments rest     flattenApps = go []     go args (EAnn _ sub) = go args sub     go args (EApp fn arg) = go (arg : args) fn     go args root = (root, args) +-- | The printed expression ends with a layout block that has no closing token.+endsWithLayoutBlock :: Expr -> Bool+endsWithLayoutBlock expr =+  case expr of+    EAnn _ sub -> endsWithLayoutBlock sub+    ECase {} -> True+    EDo {} -> True+    ELambdaCase {} -> True+    ELambdaCases {} -> True+    EMultiWayIf {} -> True+    ELetDecls _ body -> endsWithLayoutBlock body+    ELambdaPats _ body -> endsWithLayoutBlock body+    EIf _ _ no -> endsWithLayoutBlock no+    EApp _ arg -> endsWithLayoutBlock arg+    EInfix _ _ rhs -> endsWithLayoutBlock rhs+    ENegate inner -> endsWithLayoutBlock inner+    EProc {} -> True+    _ -> False+ prettyCommaSeparated :: (a -> Doc ann) -> [a] -> Doc ann prettyCommaSeparated render items =   case map render items of     [] -> mempty-    rendered -> hsep (punctuate comma rendered)+    rendered -> prettyCommaBlock rendered +-- | Items separated by commas. Each line gets as many items as fit.+prettyCommaFill :: [Doc ann] -> Doc ann+prettyCommaFill items = nest 2 (concatWith (\x y -> x <> comma <> softline <> y) items)++-- | Items separated by commas. When they do not fit on the line, each item+-- after the first starts a new line.+prettyCommaBlock :: [Doc ann] -> Doc ann+prettyCommaBlock items = group (nest 2 (concatWith (\x y -> x <> comma <> line <> y) items))+ prettyBarSeparated :: [Doc ann] -> Doc ann prettyBarSeparated items =   case items of     [] -> mempty-    firstItem : restItems -> hang 1 (vsep (firstItem : map ("|" <+>) restItems))+    firstItem : restItems -> group (hang 1 (vsep (firstItem : map ("|" <+>) restItems)))  prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann prettyTupleBody tupleFlavor inner =@@ -1360,23 +1458,25 @@ prettyGuardedRhsBodyBlock arrow grhs =   let guards = guardedRhsGuards grhs       body = guardedRhsBody grhs-   in "|"-        <+> prettyGuardQualifiersLayout guards-        <> hardline-        <> " "-        <> pretty arrow-        <+> prettyExpr body+   in group+        ( "|"+            <+> prettyGuardQualifiersLayout guards+            <> spacedLine+            <> pretty arrow+            <+> prettyExpr body+        )  prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann prettyCaseGuardedRhsBlock prettyBody grhs =   let guards = guardedRhsGuards grhs       body = guardedRhsBody grhs-   in "|"-        <+> prettyGuardQualifiersLayout guards-        <> hardline-        <> " "-        <> "->"-        <+> nest 2 (prettyBody body)+   in group+        ( "|"+            <+> prettyGuardQualifiersLayout guards+            <> spacedLine+            <> "->"+            <+> nest 2 (prettyBody body)+        )  prettyGuardedCaseAlt :: Doc ann -> (body -> Doc ann) -> [GuardedRhs body] -> Doc ann prettyGuardedCaseAlt headDoc prettyBody grhss =@@ -1384,18 +1484,46 @@     [] -> headDoc     [firstGrhs] -> headDoc <+> firstGrhs     firstGrhs : restGrhss ->-      headDoc <+> firstGrhs <> nest 2 (hardline <> vsep restGrhss)+      headDoc <+> firstGrhs <> nest 2 (hardline <> hardVsep restGrhss)  prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann-prettyMultiWayIfRhss rhss = vsep (map (prettyGuardedRhsBodyBlock "->") rhss)+prettyMultiWayIfRhss rhss = hardVsep (map (prettyGuardedRhsBodyBlock "->") rhss) +-- | Put the alternatives of a multi-way @if@ in a layout block that starts to+-- the right of the @if@ keyword and also to the right of the current+-- indentation.+--+-- The alternatives are an implicit layout block that opens at the first @|@.+-- A later line at the same column as that @|@, or further right, continues the+-- last alternative.  It does not close the block.  The enclosing expression+-- puts its continuation lines relative to the current indentation, which can+-- be further right than the @if@ keyword.  Thus the block must also clear the+-- indentation, or the printed module does not parse to the same syntax tree.+prettyMultiWayIfBlock :: Doc ann -> Doc ann+prettyMultiWayIfBlock alternatives =+  column+    ( \col ->+        nesting+          ( \indent ->+              let target = max (col + 1) (indent + multiWayIfBarOffset)+               in pretty (T.replicate (target - col) " ") <> nest (target - indent) alternatives+          )+    )++-- | The least distance between the current indentation and the @|@ of a+-- multi-way @if@.  Each continuation line that the pretty-printer puts after a+-- sub-expression is at most two columns to the right of the indentation of that+-- sub-expression.  Three columns thus always close the block.+multiWayIfBarOffset :: Int+multiWayIfBarOffset = 3+ prettyGuardQualifiersLayout :: [GuardQualifier] -> Doc ann prettyGuardQualifiersLayout qualifiers =   case map prettyGuardQualifier qualifiers of     [] -> mempty     [firstQualifier] -> firstQualifier     firstQualifier : restQualifiers ->-      firstQualifier <> nest 2 (hardline <> vsep (map (comma <+>) restQualifiers))+      group (firstQualifier <> nest 2 (line' <> concatWith (\x y -> x <> line' <> y) (map (comma <+>) restQualifiers)))  prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann prettyCaseExpr layout scrutinee alts =@@ -1406,7 +1534,7 @@  prettyCaseLayout :: [Doc ann] -> Doc ann prettyCaseLayout [] = " " <> spacedBraces mempty-prettyCaseLayout alts = nest 2 (hardline <> vsep alts)+prettyCaseLayout alts = nest 2 (hardline <> hardVsep alts)  prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) =@@ -1426,13 +1554,15 @@     GuardAnn _ inner -> prettyGuardQualifier inner     GuardExpr expr -> prettyExpr expr     GuardPat pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr-    GuardLet decls -> prettyLetDecls decls+    -- The let block has no closing token. On one line, the guard arrow can+    -- go into the block, for example into a type signature.+    GuardLet decls -> prettyLetDecls decls <> noFlat  prettyLetDecls :: [Decl] -> Doc ann prettyLetDecls decls   | null decls = "let" <+> spacedBraces mempty   | otherwise =-      "let" <+> align (vsep (concatMap prettyDeclLines decls))+      "let" <+> align (hardVsep (concatMap prettyDeclLines decls))  prettyDoFlavor :: DoFlavor -> Doc ann prettyDoFlavor DoPlain = "do"@@ -1450,7 +1580,7 @@ prettyLayoutStatements prettyStmt stmts =   case map prettyStmt stmts of     [] -> mempty-    rendered -> vsep rendered+    rendered -> hardVsep rendered  prettyDoStmt :: DoStmt Expr -> Doc ann prettyDoStmt stmt =@@ -1469,12 +1599,12 @@     EAnn _ sub -> prettyExprAtStatementStart sub     EOverloadedLabel _ raw -> pretty raw     EApp {} -> prettyAppWith prettyExprAtStatementStart expr-    ETypeApp fn ty -> nest 2 (prettyExprAtStatementStart fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty)-    EInfix lhs op rhs -> nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs)-    ESectionL lhs op -> nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op)-    ETypeSig inner ty -> nest 2 (prettyExprAtStatementStart inner) <> nest 1 (hardline <> "::" <+> prettyType ty)+    ETypeApp fn ty -> group (nest 2 (prettyExprAtStatementStart fn) <> nest 1 (spacedLine <> prettyTypeAppArg ty))+    EInfix lhs op rhs -> group (nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (line <> prettyNameInfixOp op <+> prettyExpr rhs))+    ESectionL lhs op -> group (nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (spacedLine <> prettyNameInfixOp op))+    ETypeSig inner ty -> group (nest 2 (prettyExprAtStatementStart inner) <> nest 1 (line <> "::" <+> prettyType ty))     ERecordUpd base fields ->-      prettyExprAtStatementStart base <+> braces (hsep (punctuate comma (map prettyBinding fields)))+      prettyExprAtStatementStart base <+> braces (prettyCommaBlock (map prettyBinding fields))     EGetField base field ->       prettyExprAtStatementStart base <> "." <> prettyName field     _ -> prettyExpr expr@@ -1489,17 +1619,17 @@     CmdArrApp lhs HsHigherOrderApp rhs ->       prettyExpr lhs <+> "-<<" <+> prettyExpr rhs     CmdInfix l op r ->-      nest 2 (prettyCmd l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r)+      group (nest 2 (prettyCmd l) <> nest 1 (spacedLine <> prettyNameInfixOp op <+> prettyCmd r))     CmdDo stmts ->       "do" <> nest 2 (prettyDoLayout prettyCmdStmt stmts)     CmdIf cond yes no ->-      "if" <+> prettyExpr cond <+> "then" <+> prettyCmd yes <+> "else" <+> prettyCmd no+      group ("if" <+> prettyExpr cond <> nest 2 (line <> "then" <+> prettyCmd yes <> line <> "else" <+> prettyCmd no))     CmdCase scrut alts ->       "case" <+> prettyExpr scrut <+> "of" <> prettyCaseLayout (map prettyCmdCaseAlt alts)     CmdLet decls body ->       case decls of         [] -> prettyLetDecls decls <+> "in" <+> prettyCmd body-        _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyCmd body))+        _ -> group (align (prettyLetDecls decls <> nest 2 (line <> "in" <+> prettyCmd body)))     CmdLam pats body ->       "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyCmd body     CmdApp c e ->@@ -1526,7 +1656,7 @@     CmdArrApp lhs HsHigherOrderApp rhs ->       prettyExprAtStatementStart lhs <+> "-<<" <+> prettyExpr rhs     CmdInfix l op r ->-      nest 2 (prettyCmdAtStatementStart l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r)+      group (nest 2 (prettyCmdAtStatementStart l) <> nest 1 (spacedLine <> prettyNameInfixOp op <+> prettyCmd r))     CmdApp c e ->       prettyCmdAtStatementStart c <+> prettyExpr e     _ -> prettyCmd cmd@@ -1548,7 +1678,7 @@  prettyGuardedRhssBlock :: [GuardedRhs Expr] -> Maybe [Decl] -> Doc ann prettyGuardedRhssBlock guards whereDecls =-  vsep (map prettyGuardedRhsBlock guards)+  hardVsep (map prettyGuardedRhsBlock guards)     <> case whereDecls of       Nothing -> mempty       Just _ -> hardline <> prettyWhereClauseBare whereDecls@@ -1599,7 +1729,7 @@       ["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity]     eqsPart Nothing = []     eqsPart (Just []) = ["where", spacedBraces mempty]-    eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> vsep (map prettyTypeFamilyEq eqs))]+    eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> hardVsep (map prettyTypeFamilyEq eqs))]  prettyTypeFamilyEq :: TypeFamilyEq -> Doc ann prettyTypeFamilyEq eq =

@@ -855,6 +855,7 @@     PStrict inner -> "PStrict" <+> parens (docPattern inner)     PIrrefutable inner -> "PIrrefutable" <+> parens (docPattern inner)     PNegLit lit -> "PNegLit" <+> parens (docLiteral lit)+    PNPlusK name lit -> "PNPlusK" <+> docUnqualifiedName name <+> parens (docLiteral lit)     PParen inner -> "PParen" <+> parens (docPattern inner)     PRecord name fields' hasWildcard -> "PRecord" <+> docName name <+> braces (hsep (punctuate comma ([docPatternRecordField recordField | recordField <- fields'] ++ [".." | hasWildcard])))     PTypeSig inner ty -> "PTypeSig" <+> parens (docPattern inner) <+> parens (docType ty)

@@ -1439,6 +1439,9 @@     PIrrefutable Pattern   | -- | @-1@     PNegLit Literal+  | -- | @n+1@, an n+k pattern.  It needs the @NPlusKPatterns@ extension.+    -- The literal is always a non-negative integer literal.+    PNPlusK UnqualifiedName Literal   | -- | @(pat)@     PParen Pattern   | -- | @T { x = p, y, .. }@

@@ -7,11 +7,17 @@  module Aihc.Parser.Types   ( TokStream (..),+    TraceEntry (..),+    Trace (..),     mkTokStream,     mkTokStreamModule,     mkTokStreamFromTokens,     setTokStreamLayout,     setTokStreamPendingPragmas,+    enableTokStreamTrace,+    discardLastTraceEntry,+    discardTraceEntriesFrom,+    discardTraceRange,     runTokStreamParser,     ParserErrorComponent (..),     FoundToken (..),@@ -101,6 +107,10 @@     -- | Whether this stream has already emitted TkEOF.     -- After EOF is emitted, 'take1_' returns Nothing.     tokStreamEOFEmitted :: !Bool,+    -- | The tokens that the parser took from this stream, newest first. The+    -- trace is 'Nothing' unless a caller enables it with+    -- 'enableTokStreamTrace', because a trace keeps every token alive.+    tokStreamTrace :: !(Maybe Trace),     -- | Memoized result of stepping this stream by one token. Lookahead and     -- backtracking step the same position many times; sharing the successor     -- means the layout transition for each raw token runs once.@@ -110,6 +120,22 @@     tokStreamNext :: Maybe (LexToken, TokStream)   } +-- | One token that the parser took from the stream. The token can be real or+-- virtual. A discarded token is a token that the parser took but did not keep+-- in the AST, for example a trailing comma or an extra semicolon.+data TraceEntry = TraceEntry+  { traceToken :: !LexToken,+    traceDiscarded :: !Bool+  }+  deriving (Eq, Show, Generic, NFData)++-- | The entries of a token trace, newest first, with their count.+data Trace = Trace+  { traceLength :: !Int,+    traceEntries :: [TraceEntry]+  }+  deriving (Eq, Show, Generic, NFData)+ -- -- Manual Eq instance — we skip tokStreamRawTokens since list position is not -- -- efficiently comparable and Megaparsec tracks offset separately. -- instance Eq TokStream where@@ -158,6 +184,7 @@         Nothing         (mkExtensionSet exts)         False+        Nothing  -- | Create a TokStream for parsing full modules (with module-body layout). -- Also bootstraps LANGUAGE pragma extensions from the module header.@@ -172,6 +199,7 @@         Nothing         (mkExtensionSet effectiveExts)         False+        Nothing   where     headerSettings = readModuleHeaderExtensions input     effectiveExts = applyImpliedExtensions (foldr applyExtensionSetting baseExts headerSettings)@@ -189,6 +217,7 @@         Nothing         (mkExtensionSet [])         False+        Nothing  -- | Replace the layout state and buffer of a stream. The result is a fresh -- stream with a consistent memoized successor.@@ -202,6 +231,7 @@     (tokStreamPrevToken ts)     (tokStreamExtensionSet ts)     (tokStreamEOFEmitted ts)+    (tokStreamTrace ts)  -- | Replace the pending hidden pragmas of a stream. setTokStreamPendingPragmas :: [Pragma] -> TokStream -> TokStream@@ -214,10 +244,71 @@     (tokStreamPrevToken ts)     (tokStreamExtensionSet ts)     (tokStreamEOFEmitted ts)+    (tokStreamTrace ts) +-- | Start the trace of a stream. The trace then records each token that the+-- parser takes. Use 'discardLastTraceEntry' to mark a token that the AST does+-- not keep.+enableTokStreamTrace :: TokStream -> TokStream+enableTokStreamTrace ts =+  buildTokStream+    (tokStreamRawTokens ts)+    (tokStreamLayoutState ts)+    (tokStreamBuffer ts)+    (tokStreamPendingPragmas ts)+    (tokStreamPrevToken ts)+    (tokStreamExtensionSet ts)+    (tokStreamEOFEmitted ts)+    (Just (Trace 0 []))++-- | Mark the newest trace entry as discarded. This has no effect when the+-- trace is not enabled.+discardLastTraceEntry :: TokStream -> TokStream+discardLastTraceEntry ts =+  case tokStreamTrace ts of+    Just (Trace len _) -> discardTraceEntriesFrom (len - 1) ts+    Nothing -> ts++-- | Mark each trace entry from the given position as discarded. Position 0 is+-- the oldest entry. Use the 'traceLength' from before a parser to mark each+-- token that the parser took. This has no effect when the trace is not+-- enabled.+discardTraceEntriesFrom :: Int -> TokStream -> TokStream+discardTraceEntriesFrom start ts =+  case tokStreamTrace ts of+    Just (Trace len _) -> discardTraceRange start len ts+    Nothing -> ts++-- | Mark the trace entries at positions @start@ to @end - 1@ as discarded.+-- Position 0 is the oldest entry. This has no effect when the trace is not+-- enabled.+discardTraceRange :: Int -> Int -> TokStream -> TokStream+discardTraceRange start end ts =+  case tokStreamTrace ts of+    Just (Trace len entries)+      | start < end && start < len ->+          buildTokStream+            (tokStreamRawTokens ts)+            (tokStreamLayoutState ts)+            (tokStreamBuffer ts)+            (tokStreamPendingPragmas ts)+            (tokStreamPrevToken ts)+            (tokStreamExtensionSet ts)+            (tokStreamEOFEmitted ts)+            (Just (Trace len (markRange entries)))+      where+        -- The entries are newest first, so position p is at index len - 1 - p.+        newest = len - min end len+        count = min end len - start+        markRange entries' =+          let (newer, rest) = splitAt newest entries'+              (marked, older) = splitAt count rest+           in newer <> map (\entry -> entry {traceDiscarded = True}) marked <> older+    _ -> ts+ -- | Build a stream whose memoized successor is computed from its fields.-buildTokStream :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> TokStream-buildTokStream rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted =+buildTokStream :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> Maybe Trace -> TokStream+buildTokStream rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted trace =   let ts =         TokStream           { tokStreamRawTokens = rawTokens,@@ -227,6 +318,7 @@             tokStreamPrevToken = prevToken,             tokStreamExtensionSet = extensionSet,             tokStreamEOFEmitted = eofEmitted,+            tokStreamTrace = trace,             tokStreamNext = stepOne ts           }    in ts@@ -234,13 +326,13 @@ -- | Advance through layout and hidden tokens until the stream is ready for -- 'stepOne'. Keeping the stream fields separate lets a token step normalize -- its successor without first allocating an intermediate 'TokStream'.-normalizeTokStreamParts :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> TokStream-normalizeTokStreamParts rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted+normalizeTokStreamParts :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> Maybe Trace -> TokStream+normalizeTokStreamParts rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted trace   | eofEmitted = finish rawTokens layoutState buffer pendingPragmas   | otherwise = go rawTokens layoutState buffer pendingPragmas   where     finish rawTokens' layoutState' buffer' pendingPragmas' =-      buildTokStream rawTokens' layoutState' buffer' pendingPragmas' prevToken extensionSet eofEmitted+      buildTokStream rawTokens' layoutState' buffer' pendingPragmas' prevToken extensionSet eofEmitted trace      go rawTokens' layoutState' buffer' pendingPragmas' =       case buffer' of@@ -300,6 +392,7 @@                   (Just tok)                   (tokStreamExtensionSet ts)                   isEOF+                  (fmap (\(Trace len entries) -> Trace (len + 1) (TraceEntry tok False : entries)) (tokStreamTrace ts))            in Just (tok, next)         [] ->           Nothing@@ -352,7 +445,7 @@               },           MP.stateParseErrors = []         }-    detachedStream = buildTokStream [] (tokStreamLayoutState ts) [] [] Nothing (tokStreamExtensionSet ts) True+    detachedStream = buildTokStream [] (tokStreamLayoutState ts) [] [] Nothing (tokStreamExtensionSet ts) True Nothing  instance Stream TokStream where   type Token TokStream = LexToken

@@ -147,6 +147,20 @@     ParseErr bundle ->       assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "<test>" Nothing bundle) +assertParsedStrippedModuleShapeRoundTrip :: ParserConfig -> Text -> Assertion+assertParsedStrippedModuleShapeRoundTrip config source =+  case parseModule config source of+    ([], modu) ->+      let stripped = stripParens (stripAnnotations modu)+          rendered = renderPretty stripped+       in case parseModule config rendered of+            ([], reparsed) ->+              assertEqualShorthand (T.unpack rendered) stripped (stripAnnotations (stripParens reparsed))+            (errs, _) ->+              assertFailure ("expected pretty-printed module to reparse, got:\n" <> formatParseErrors "<test>" (Just rendered) errs)+    (errs, _) ->+      assertFailure ("expected parse success for:\n" <> T.unpack source <> "\n" <> formatParseErrors "<test>" (Just source) errs)+ assertParsedModulePrettyContains :: Text -> Text -> Assertion assertParsedModulePrettyContains source expected =   case parseModule defaultConfig source of@@ -290,10 +304,13 @@             testCase "generated expressions can include explicit type syntax" test_generatedExpressionsCanIncludeExplicitTypeSyntax,             testCase "pretty-prints negated layout-ending list-comprehension bodies" test_prettyNegatedLayoutEndingListCompBody,             testCase "pretty-prints layout let guards in multi-way if" test_prettyLayoutLetGuardInMultiWayIf,+            testCase "pretty-prints typed let guards in case alternatives on separate lines" test_prettyTypedLetGuardInCaseAlt,             testCase "pretty-prints multi-way if left operands using layout" test_prettyMultiWayIfInfixLhs,             testCase "pretty-prints multi-way if left operands inside do using layout" test_prettyMultiWayIfInfixLhsInsideDo,             testCase "pretty-prints multi-way if left operands inside unboxed tuples with parentheses" test_prettyMultiWayIfInfixLhsInsideUnboxedTuple,             testCase "pretty-prints multi-way if left operands inside unboxed sums with parentheses" test_prettyMultiWayIfInfixLhsInsideUnboxedSum,+            testCase "pretty-prints multi-way if left operands in infix chains using layout" test_prettyMultiWayIfNestedInfixLhs,+            testCase "pretty-prints multi-way if parallel comprehension bodies using layout" test_prettyMultiWayIfParallelListCompBody,             testCase "pretty-prints lambda-case applicative chains without extra parens" test_prettyLambdaCaseApplicativeChain,             testCase "pretty-prints TH splices before record dots with parentheses" test_prettySpliceRecordDotBase,             testCase "rejects compact explicit type namespace TH splices" test_compactExplicitTypeNamespaceTHSplicesReject,@@ -324,6 +341,12 @@             testCase "parenthesizes multi-way if view expressions ending with type signatures in decls" test_viewExprMultiWayIfTypeSigParens,             testCase "parenthesizes infix view expressions in lambda-cases" test_viewExprInfixLambdaCasesParens,             testCase "leaves block infix lhs view expressions bare" test_viewExprBlockInfixLhsNoParens,+            testCase "breaks a long record after each comma" test_prettyLongRecordBreaksAfterCommas,+            testCase "fills the arguments of a long application" test_prettyLongApplicationFillsArguments,+            testCase "breaks a long type signature before each arrow" test_prettyLongTypeSignatureBreaksArrows,+            testCase "breaks a long data declaration before each constructor" test_prettyLongDataDeclBreaksConstructors,+            testCase "fills a long import list" test_prettyLongImportListFills,+            testCase "breaks a long instance head after its context" test_prettyLongInstanceHeadBreaksContext,             testCase "leaves view expression block arguments bare" test_viewExprBlockArgumentNoParens,             testCase "leaves multi-way-if app infix lhs view expressions bare" test_viewExprMultiWayIfAppInfixLhsNoParens,             testCase "parenthesizes non-final let block arguments in view expressions" test_viewExprNonfinalLetBlockArgumentParens,@@ -1407,6 +1430,18 @@         """   assertParsedStrippedExprShapeRoundTrip config source +test_prettyTypedLetGuardInCaseAlt :: Assertion+test_prettyTypedLetGuardInCaseAlt = do+  let config = defaultConfig {parserExtensions = [LambdaCase]}+      source =+        """+        \\case+          _ | let _ = []+                    :: _+             -> []+        """+  assertParsedStrippedExprShapeRoundTrip config source+ test_prettyMultiWayIfInfixLhs :: Assertion test_prettyMultiWayIfInfixLhs = do   let config = defaultConfig {parserExtensions = [MultiWayIf]}@@ -1457,6 +1492,43 @@         """   assertParsedStrippedExprShapeRoundTrip config source +-- Two levels of infix nesting put the continuation line at the column of the+-- @|@ of the multi-way if.  The @|@ must thus move to the right of the+-- continuation line.  See issue #54.+test_prettyMultiWayIfNestedInfixLhs :: Assertion+test_prettyMultiWayIfNestedInfixLhs = do+  let config = defaultConfig {parserExtensions = [MultiWayIf]}+      source =+        """+        ((if | True+             ->+              ())+          `a` ())+         `a` ()+        """+  assertParsedStrippedExprShapeRoundTrip config source++-- The @|@ of a parallel list comprehension can land at the column of the @|@+-- of a multi-way if in the body of that comprehension.  See issue #54.+test_prettyMultiWayIfParallelListCompBody :: Assertion+test_prettyMultiWayIfParallelListCompBody = do+  let config =+        defaultConfig+          { parserExtensions = [MultiWayIf, ImplicitParams, UnboxedSums, ParallelListComp]+          }+      source =+        """+        _ = []+          where+            ?x = (# ([(if | []+                           ->+                            [])+                      | []+                      | let {  }]+                     `a` []) | |  #)+        """+  assertParsedStrippedModuleShapeRoundTrip config source+ test_prettyLambdaCaseApplicativeChain :: Assertion test_prettyLambdaCaseApplicativeChain = do   let config = defaultConfig {parserExtensions = [LambdaCase]}@@ -1801,6 +1873,42 @@   assertParsedStrippedDeclShapeRoundTrip config "_ = [] where ((do [] `a` []) -> _) = []"   assertParsedStrippedPatternShapeRoundTrip config "(((if | [] -> []) `a` []) -> _)" +test_prettyLongRecordBreaksAfterCommas :: Assertion+test_prettyLongRecordBreaksAfterCommas =+  assertParsedModulePrettyContains+    "module M where\nr = R {fieldOne = valueOne, fieldTwo = valueTwo, fieldThree = valueThree, fieldFour = valueFour}\n"+    "r = R {fieldOne = valueOne,\n  fieldTwo = valueTwo,\n  fieldThree = valueThree,\n  fieldFour = valueFour}"++test_prettyLongApplicationFillsArguments :: Assertion+test_prettyLongApplicationFillsArguments =+  assertParsedModulePrettyContains+    "module M where\nf = someFunction argumentOne argumentTwo argumentThree argumentFour argumentFive argumentSix\n"+    "f = someFunction argumentOne argumentTwo argumentThree argumentFour argumentFive\n  argumentSix"++test_prettyLongTypeSignatureBreaksArrows :: Assertion+test_prettyLongTypeSignatureBreaksArrows =+  assertParsedModulePrettyContains+    "module M where\nf :: FirstArgumentType -> SecondArgumentType -> ThirdArgumentType -> FourthArgumentType -> ResultType\n"+    "f :: FirstArgumentType\n  -> SecondArgumentType\n  -> ThirdArgumentType\n  -> FourthArgumentType\n  -> ResultType"++test_prettyLongDataDeclBreaksConstructors :: Assertion+test_prettyLongDataDeclBreaksConstructors =+  assertParsedModulePrettyContains+    "module M where\ndata Colour = Red | Green | Blue | Cyan | Magenta | Yellow | Black | White deriving (Eq, Show)\n"+    "data Colour\n  = Red\n  | Green\n  | Blue\n  | Cyan\n  | Magenta\n  | Yellow\n  | Black\n  | White\n  deriving (Eq, Show)"++test_prettyLongImportListFills :: Assertion+test_prettyLongImportListFills =+  assertParsedModulePrettyContains+    "module M where\nimport Data.List (sortBy, groupBy, intercalate, isPrefixOf, isSuffixOf, partition)\n"+    "import Data.List (sortBy, groupBy, intercalate, isPrefixOf, isSuffixOf,\n  partition)"++test_prettyLongInstanceHeadBreaksContext :: Assertion+test_prettyLongInstanceHeadBreaksContext =+  assertParsedModulePrettyContains+    "module M where\ninstance (Show a, Show b, Show c, Show d) => Show (VeryLongTypeName a b c d) where\n  show _ = \"\"\n"+    "instance (Show a, Show b, Show c, Show d)\n  => Show (VeryLongTypeName a b c d) where"+ test_viewExprBlockInfixLhsNoParens :: Assertion test_viewExprBlockInfixLhsNoParens = do   let source =@@ -1813,9 +1921,7 @@         """       expected =         """-        f [case [] of {  }-         + []-         -> _] = []+        f [case [] of {  } + [] -> _] = []         """   assertParsedModulePrettyContains source expected 

@@ -0,0 +1,6 @@+extensions: [NPlusKPatterns]+input: |+  n+1+ast: |-+  PNPlusK UnqualifiedName {"n"} (LitInt 1 TInteger)+status: pass

@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NPlusKPatterns #-}++module NPlusKPatternsCaseAlt where++predecessor x = case x of+  0 -> 0+  n+1 -> n

@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NPlusKPatterns #-}++module NPlusKPatternsFunArg where++takeN 0 _ = []+takeN (n+1) (x:xs) = x : takeN n xs

@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NPlusKPatterns #-}++module NPlusKPatternsPatBind where++(m+1) = 3++n + 1 = n++value = xs+  where+    (k+1 : xs) = [3, 4]

@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE NPlusKPatterns #-}+{-# LANGUAGE ScopedTypeVariables #-}++module NPlusKPatternsTypedPatBind where++a + 0 :: Int = 5++b + 0 : bs :: [Int] = [5]++n + 1 = n

@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}++module TransformCaseBeforeKeyword where++grouped xs = [x | x <- xs, then group by case x of _ -> x using groupWith]++sorted xs = [x | x <- xs, then sortWith by case x of _ -> x]

@@ -0,0 +1,9 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TransformListComp #-}++module TransformMultiWayIfBeforeKeyword where++grouped xs = [x | x <- xs, then group by if | x -> x using groupWith]++sorted xs = [x | x <- xs, then sortWith by if | x -> x]

@@ -5,8 +5,12 @@   ) where +import Aihc.Parser (ParserConfig (..), TraceEntry (..), defaultConfig, parseModuleWithTrace, tokenKindWithoutSpacing)+import Aihc.Parser.Lex (LexToken (..))+import Aihc.Parser.Syntax qualified as Syntax import Control.Monad (when) import Data.Text (Text)+import Data.Text qualified as T import Data.Text.IO qualified as TIO import ExtensionSupport   ( CaseMeta (..),@@ -16,7 +20,10 @@     evaluateCaseFromFile,     evaluateCaseText,     loadOracleCases,+    preprocessCaseSource,   )+import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty)+import Prettyprinter.Render.Text (renderStrict) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure, testCase, testCaseInfo) @@ -26,7 +33,56 @@   checks <- mapM mkCaseTest cases   framework <- frameworkTests   summary <- mkSummaryTest cases-  pure (testGroup "oracle" (checks <> [framework, summary]))+  traces <- mapM mkTraceTest (filter ((== ExpectPass) . caseExpected) cases)+  pure (testGroup "oracle" (checks <> [framework, summary, testGroup "token trace" traces]))++-- | The parser gives the same token trace for a source file and for its+-- pretty-printed form, when the discarded tokens are removed. A formatter+-- pairs the tokens of the two files by their position in this trace.+mkTraceTest :: CaseMeta -> IO TestTree+mkTraceTest meta = do+  source <- TIO.readFile (caseSourcePath meta)+  pure (testCase (caseId meta) (assertTraceMatches meta (preprocessCaseSource meta source)))++assertTraceMatches :: CaseMeta -> Text -> Assertion+assertTraceMatches meta source =+  case parseModuleWithTrace config source of+    (_ : _, _, _) -> assertFailure "the source does not parse"+    ([], modu, sourceTrace) ->+      let rendered = renderStrict (layoutPretty defaultLayoutOptions (pretty modu))+       in case parseModuleWithTrace config rendered of+            (_ : _, _, _) -> assertFailure "the pretty-printed source does not parse"+            ([], _, renderedTrace) ->+              let kept = filter (not . traceDiscarded)+                  sourceKept = kept sourceTrace+                  renderedKept = kept renderedTrace+                  kindOf = tokenKindWithoutSpacing . lexTokenKind . traceToken+                  sameKind a b = kindOf a == kindOf b+                  common = length (takeWhile id (zipWith sameKind sourceKept renderedKept))+               in when (common < length sourceKept || common < length renderedKept) $+                    assertFailure+                      ( "token traces differ at entry "+                          <> show common+                          <> "\nsource:   "+                          <> showEntries (drop (common - 3) sourceKept)+                          <> "\nrendered: "+                          <> showEntries (drop (common - 3) renderedKept)+                      )+  where+    config =+      defaultConfig+        { parserSourceName = caseSourcePath meta,+          parserExtensions = Syntax.effectiveExtensions Syntax.Haskell2010Edition (caseExtensions meta)+        }+    showEntries = unwords . map showEntry . take 7+    showEntry entry =+      let tok = traceToken entry+          text = lexTokenText tok+       in (if T.null text then show (lexTokenKind tok) else T.unpack text)+            <> "@"+            <> show (Syntax.sourceSpanStartLine (lexTokenSpan tok))+            <> ":"+            <> show (Syntax.sourceSpanStartCol (lexTokenSpan tok))  mkCaseTest :: CaseMeta -> IO TestTree mkCaseTest meta = do

@@ -52,6 +52,7 @@         PLit <$> genLiteral,         PQuasiQuote <$> genQuoterName <*> genQuasiBody,         PNegLit <$> genNumericLiteral,+        genNPlusKPattern,         PSplice <$> genPatSpliceBody,         PTuple Boxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]],         PTuple Unboxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x")], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]],@@ -76,6 +77,14 @@         PIrrefutable <$> genPattern       ] +-- | Generate an n+k pattern such as @n + 1@.+-- The variable is always a variable identifier and the literal is always a+-- non-negative integer literal, because the n+k syntax allows only these.+genNPlusKPattern :: Gen Pattern+genNPlusKPattern =+  (PNPlusK . mkUnqualifiedName NameVarId <$> genVarId)+    <*> oneof [mkIntLiteral <$> chooseInteger (0, 999), mkHexLiteral <$> chooseInteger (0, 255)]+ genViewPatternWith :: Gen Pattern genViewPatternWith =   PView <$> genExpr <*> genPattern@@ -229,6 +238,10 @@       PNegLit lit ->         [PLit lit]           <> [PNegLit shrunk | shrunk <- shrinkNumericLiteral lit]+      PNPlusK name lit ->+        [PVar name]+          <> [PNPlusK name' lit | name' <- shrinkUnqualifiedName name]+          <> [PNPlusK name lit' | lit' <- shrinkLiteral lit]       PParen inner ->         [inner] <> [PParen inner' | inner' <- shrinkPattern inner]       PUnboxedSum altIdx arity inner ->

@@ -56,6 +56,7 @@           LinearTypes,           MagicHash,           MultiWayIf,+          NPlusKPatterns,           OverloadedLabels,           OverloadedRecordDot,           ParallelListComp,