aihc-parser 1.0.0.3 → 1.0.0.4

raw patch · 38 files changed

+1247/−593 lines, 38 filesdep +aihc-parserPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: aihc-parser

API changes (from Hackage documentation)

Files

• CHANGELOG.md +22/−0
• aihc-parser.cabal +64/−5
• docs/aihc-parser-supported-extensions.md +97/−0
• fuzz/Aihc/Parser/Fuzz.hs +64/−0
• src/Aihc/Parser/Internal/CheckPattern.hs +2/−2
• src/Aihc/Parser/Internal/Common.hs +158/−90
• src/Aihc/Parser/Internal/Decl.hs +43/−32
• src/Aihc/Parser/Internal/Expr.hs +107/−75
• src/Aihc/Parser/Internal/Pattern.hs +78/−50
• src/Aihc/Parser/Internal/Testing.hs +22/−0
• src/Aihc/Parser/Internal/Type.hs +76/−61
• src/Aihc/Parser/Lex.hs +41/−33
• src/Aihc/Parser/Lex/Layout.hs +1/−0
• src/Aihc/Parser/Lex/Quoted.hs +34/−31
• src/Aihc/Parser/Lex/Types.hs +4/−5
• src/Aihc/Parser/Parens.hs +4/−0
• src/Aihc/Parser/Pretty.hs +82/−97
• src/Aihc/Parser/Syntax.hs +50/−8
• src/Aihc/Parser/Types.hs +93/−81
• test/Spec.hs +51/−11
• test/Test/Fixtures/lexer/core/string-hash-latin1.yaml +6/−0
• test/Test/Fixtures/lexer/core/string-hash-non-latin1.yaml +6/−0
• test/Test/Fixtures/lexer/core/string-non-latin1-boxed.yaml +6/−0
• test/Test/Fixtures/oracle/Hackage/boltzmann-samplers-infix-case-scrutinee.hs +15/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout001-case-where.hs +7/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout002-if-then-do.hs +5/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout003-list-comprehension-closes-do.hs +12/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout004-pattern-guard-let.hs +10/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout005-else-closes-do.hs +10/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout006-guarded-do-let.hs +13/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout007-splice-closing-paren.hs +11/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout008-do-mdo-rec.hs +22/−0
• test/Test/Fixtures/oracle/Layout/ghc-layout009-explicit-let-braces.hs +6/−0
• test/Test/Fixtures/oracle/PatternSyntax/variable-leading-infix-declarations.hs +7/−0
• test/Test/Fixtures/oracle/TransformListComp/bare-if-boundaries.hs +8/−0
• test/Test/Performance/Suite.hs +2/−2
• test/Test/Properties/NoExceptions.hs +7/−9
• test/Test/Properties/ShorthandSubset.hs +1/−1

@@ -6,6 +6,28 @@  ## [Unreleased] +## [1.0.0.4] - 2026-07-26++### Added++- Added `Addr#` literal syntax and expanded GHC layout oracle coverage.+- Added a developer-only public fuzz registry for downstream property suites.+- Added a `Read` instance for `FixityAssoc` so downstream metadata containing+  operator fixities can be persisted and restored.++### Changed++- Improved parser throughput and reduced allocations across large Stackage+  inputs and deeply nested syntax.+- Moved development to the standalone+  [`ai-haskell-compiler/aihc-parser`](https://github.com/ai-haskell-compiler/aihc-parser)+  repository, including the full test, progress, doctest, fuzz, and+  compatibility CI configuration.++### Fixed++- Aligned multiline `case` scrutinee layout with GHC.+ ## [1.0.0.3] - 2026-06-01  ### Changed

@@ -1,11 +1,12 @@ cabal-version: 3.8 name: aihc-parser-version: 1.0.0.3+version: 1.0.0.4 build-type: Simple license: Unlicense license-file: LICENSE extra-doc-files: CHANGELOG.md extra-source-files:+  docs/aihc-parser-supported-extensions.md   test/Test/Fixtures/**/*.hs   test/Test/Fixtures/**/*.yaml @@ -24,17 +25,22 @@   The package is validated with golden tests and oracle-backed differential   tests against GHC. -homepage: https://github.com/ai-haskell-compiler/aihc/tree/main/components/aihc-parser-bug-reports: https://github.com/ai-haskell-compiler/aihc/issues+homepage: https://github.com/ai-haskell-compiler/aihc-parser+bug-reports: https://github.com/ai-haskell-compiler/aihc-parser/issues  source-repository head   type: git-  location: https://github.com/ai-haskell-compiler/aihc.git-  subdir: components/aihc-parser+  location: https://github.com/ai-haskell-compiler/aihc-parser.git +flag fuzz+  description: Build the developer-only QuickCheck property registry+  default: False+  manual: True+ library   exposed-modules:     Aihc.Parser+    Aihc.Parser.Internal.Testing     Aihc.Parser.Parens     Aihc.Parser.Pretty     Aihc.Parser.Shorthand@@ -76,6 +82,58 @@   ghc-options: -Wall   default-language: GHC2021 +library fuzz+  if !flag(fuzz)+    buildable: False+  visibility: public+  hs-source-dirs:+    fuzz+    test+    common++  exposed-modules:+    Aihc.Parser.Fuzz+    Test.Properties.Arb.Decl+    Test.Properties.Arb.Expr+    Test.Properties.Arb.Identifiers+    Test.Properties.Arb.Module+    Test.Properties.Arb.Pattern+    Test.Properties.Arb.Type+    Test.Properties.Arb.Utils++  other-modules:+    CppSupport+    GhcOracle+    ParserValidation+    Test.Properties.Coverage+    Test.Properties.DeclRoundTrip+    Test.Properties.ExprRoundTrip+    Test.Properties.MinimalParentheses+    Test.Properties.ModuleRoundTrip+    Test.Properties.NoExceptions+    Test.Properties.ParensIdempotency+    Test.Properties.PatternRoundTrip+    Test.Properties.ShorthandSubset+    Test.Properties.TypeRoundTrip++  build-depends:+    Diff >=1.0 && <1.1,+    QuickCheck >=2.14 && <2.19,+    aihc-cpp >=1.0 && <1.1,+    aihc-hackage >=0.1 && <0.2,+    aihc-parser,+    base >=4.19 && <5,+    bytestring >=0.10.8 && <0.13,+    containers >=0.5 && <0.9,+    deepseq >=1.4 && <1.6,+    filepath >=1.3.0.1 && <1.6,+    ghc-lib-parser >=9.14.1 && <9.15,+    prettyprinter >=1.7 && <1.8,+    text >=2.1.2 && <2.2,++  ghc-options: -Wall+  default-language: GHC2021+ test-suite spec   type: exitcode-stdio-1.0   hs-source-dirs:@@ -96,6 +154,7 @@     Aihc.Parser.Internal.Import     Aihc.Parser.Internal.Module     Aihc.Parser.Internal.Pattern+    Aihc.Parser.Internal.Testing     Aihc.Parser.Internal.Type     Aihc.Parser.Lex     Aihc.Parser.Lex.Header

@@ -0,0 +1,97 @@+# Haskell Parser Extension Support Status++## Summary++- Total Extensions: 84+- Supported: 84+- In Progress: 0++## Extension Status++| Extension                 | Status | Tests Passing |+|---------------------------|:------:|---------------|+| Arrows                    |   🟢    | 30/30         |+| BangPatterns              |   🟢    | 13/13         |+| BinaryLiterals            |   🟢    | 3/3           |+| BlockArguments            |   🟢    | 13/13         |+| CApiFFI                   |   🟢    | 4/4           |+| CPP                       |   🟢    | 8/8           |+| ConstraintKinds           |   🟢    | 8/8           |+| DataKinds                 |   🟢    | 65/65         |+| DefaultSignatures         |   🟢    | 4/4           |+| DerivingStrategies        |   🟢    | 8/8           |+| DerivingVia               |   🟢    | 7/7           |+| DoAndIfThenElse           |   🟢    | 15/15         |+| DoRec                     |   🟢    | 1/1           |+| EmptyCase                 |   🟢    | 7/7           |+| EmptyDataDecls            |   🟢    | 8/8           |+| EmptyDataDeriving         |   🟢    | 4/4           |+| ExistentialQuantification |   🟢    | 7/7           |+| ExplicitForAll            |   🟢    | 27/27         |+| ExplicitLevelImports      |   🟢    | 4/4           |+| ExplicitNamespaces        |   🟢    | 26/26         |+| ExtendedLiterals          |   🟢    | 4/4           |+| FlexibleContexts          |   🟢    | 4/4           |+| FlexibleInstances         |   🟢    | 18/18         |+| ForeignFunctionInterface  |   🟢    | 40/40         |+| FunctionalDependencies    |   🟢    | 7/7           |+| GADTSyntax                |   🟢    | 11/11         |+| GADTs                     |   🟢    | 15/15         |+| GHC2021                   |   🟢    | 44/44         |+| GHCForeignImportPrim      |   🟢    | 1/1           |+| Haskell2010               |   🟢    | 17/17         |+| HexFloatLiterals          |   🟢    | 3/3           |+| ImplicitParams            |   🟢    | 11/11         |+| ImportQualifiedPost       |   🟢    | 5/5           |+| InstanceSigs              |   🟢    | 5/5           |+| InterruptibleFFI          |   🟢    | 1/1           |+| JavaScriptFFI             |   🟢    | 1/1           |+| KindSignatures            |   🟢    | 33/33         |+| LambdaCase                |   🟢    | 23/23         |+| LinearTypes               |   🟢    | 15/15         |+| MagicHash                 |   🟢    | 24/24         |+| MultiParamTypeClasses     |   🟢    | 24/24         |+| MultiWayIf                |   🟢    | 21/21         |+| MultilineStrings          |   🟢    | 6/6           |+| NamedFieldPuns            |   🟢    | 6/6           |+| NamedWildCards            |   🟢    | 5/5           |+| NegativeLiterals          |   🟢    | 1/1           |+| NondecreasingIndentation  |   🟢    | 3/3           |+| NumericUnderscores        |   🟢    | 4/4           |+| OverlappingInstances      |   🟢    | 1/1           |+| OverloadedLabels          |   🟢    | 6/6           |+| OverloadedRecordDot       |   🟢    | 8/8           |+| PackageImports            |   🟢    | 6/6           |+| ParallelListComp          |   🟢    | 3/3           |+| PartialTypeSignatures     |   🟢    | 21/21         |+| PatternGuards             |   🟢    | 9/9           |+| PatternSynonyms           |   🟢    | 34/34         |+| PolyKinds                 |   🟢    | 14/14         |+| QualifiedDo               |   🟢    | 4/4           |+| QuantifiedConstraints     |   🟢    | 2/2           |+| QuasiQuotes               |   🟢    | 11/11         |+| RankNTypes                |   🟢    | 5/5           |+| RecordWildCards           |   🟢    | 10/10         |+| RecursiveDo               |   🟢    | 5/5           |+| RequiredTypeArguments     |   🟢    | 4/4           |+| RoleAnnotations           |   🟢    | 7/7           |+| Safe                      |   🟢    | 2/2           |+| ScopedTypeVariables       |   🟢    | 18/18         |+| StandaloneDeriving        |   🟢    | 18/18         |+| StandaloneKindSignatures  |   🟢    | 12/12         |+| StarIsType                |   🟢    | 4/4           |+| TemplateHaskell           |   🟢    | 68/68         |+| TemplateHaskellQuotes     |   🟢    | 14/14         |+| TransformListComp         |   🟢    | 18/18         |+| TupleSections             |   🟢    | 4/4           |+| TypeAbstractions          |   🟢    | 5/5           |+| TypeApplications          |   🟢    | 13/13         |+| TypeData                  |   🟢    | 1/1           |+| TypeFamilies              |   🟢    | 61/61         |+| TypeFamilyDependencies    |   🟢    | 4/4           |+| TypeOperators             |   🟢    | 71/71         |+| UnboxedSums               |   🟢    | 13/13         |+| UnboxedTuples             |   🟢    | 22/22         |+| UnicodeSyntax             |   🟢    | 21/21         |+| ViewPatterns              |   🟢    | 26/26         |+

@@ -0,0 +1,64 @@+-- | Continuously runnable QuickCheck properties owned by @aihc-parser@.+module Aihc.Parser.Fuzz+  ( parserFuzzProperties,+  )+where++import Test.Properties.DeclRoundTrip (prop_declPrettyRoundTrip)+import Test.Properties.ExprRoundTrip (prop_exprPrettyRoundTrip)+import Test.Properties.MinimalParentheses (prop_minimalParenthesesExpr, prop_minimalParenthesesPattern, prop_minimalParenthesesSignatureType, prop_minimalParenthesesType)+import Test.Properties.ModuleRoundTrip (prop_modulePrettyRoundTrip, prop_moduleValidator)+import Test.Properties.NoExceptions+  ( prop_declParserArbitraryTokensNoExceptions,+    prop_exprParserArbitraryTokensNoExceptions,+    prop_genLexTokenKindConstructorCoverage,+    prop_importDeclParserArbitraryTokensNoExceptions,+    prop_lexerArbitraryTextNoExceptions,+    prop_moduleHeaderParserArbitraryTokensNoExceptions,+    prop_moduleParserArbitraryTokensNoExceptions,+    prop_patternParserArbitraryTokensNoExceptions,+    prop_preprocessorArbitraryTextNoExceptions,+    prop_typeParserArbitraryTokensNoExceptions,+  )+import Test.Properties.ParensIdempotency (prop_declParensIdempotent, prop_exprParensIdempotent, prop_moduleParensIdempotent, prop_patternParensIdempotent, prop_typeParensIdempotent)+import Test.Properties.PatternRoundTrip (prop_patternPrettyRoundTrip)+import Test.Properties.ShorthandSubset (prop_shorthandDeclSubsetOfShow, prop_shorthandExprSubsetOfShow, prop_shorthandLexTokenSubsetOfShow, prop_shorthandModuleSubsetOfShow, prop_shorthandTypeSubsetOfShow)+import Test.Properties.TypeRoundTrip (prop_typePrettyRoundTrip)+import Test.QuickCheck (Property, Testable, property)++parserFuzzProperties :: [(String, Property)]+parserFuzzProperties =+  [ named "expr paren insertion is minimal" prop_minimalParenthesesExpr,+    named "pattern paren insertion is minimal" prop_minimalParenthesesPattern,+    named "signature type paren insertion is minimal" prop_minimalParenthesesSignatureType,+    named "type paren insertion is minimal" prop_minimalParenthesesType,+    named "generated expr AST pretty-printer round-trip" prop_exprPrettyRoundTrip,+    named "generated decl AST pretty-printer round-trip" prop_declPrettyRoundTrip,+    named "generated module AST pretty-printer round-trip" prop_modulePrettyRoundTrip,+    named "generated module AST validator" prop_moduleValidator,+    named "generated pattern AST pretty-printer round-trip" prop_patternPrettyRoundTrip,+    named "generated type AST pretty-printer round-trip" prop_typePrettyRoundTrip,+    named "module paren insertion is idempotent" prop_moduleParensIdempotent,+    named "decl paren insertion is idempotent" prop_declParensIdempotent,+    named "expr paren insertion is idempotent" prop_exprParensIdempotent,+    named "pattern paren insertion is idempotent" prop_patternParensIdempotent,+    named "type paren insertion is idempotent" prop_typeParensIdempotent,+    named "module shorthand is a subset of Show" prop_shorthandModuleSubsetOfShow,+    named "decl shorthand is a subset of Show" prop_shorthandDeclSubsetOfShow,+    named "expr shorthand is a subset of Show" prop_shorthandExprSubsetOfShow,+    named "type shorthand is a subset of Show" prop_shorthandTypeSubsetOfShow,+    named "lex token shorthand is a subset of Show" prop_shorthandLexTokenSubsetOfShow,+    named "lex token kind generator covers constructors" prop_genLexTokenKindConstructorCoverage,+    named "no exceptions.preprocessor accepts arbitrary text" prop_preprocessorArbitraryTextNoExceptions,+    named "no exceptions.lexer accepts arbitrary text" prop_lexerArbitraryTextNoExceptions,+    named "no exceptions.module parser accepts arbitrary tokens" prop_moduleParserArbitraryTokensNoExceptions,+    named "no exceptions.expr parser accepts arbitrary tokens" prop_exprParserArbitraryTokensNoExceptions,+    named "no exceptions.type parser accepts arbitrary tokens" prop_typeParserArbitraryTokensNoExceptions,+    named "no exceptions.pattern parser accepts arbitrary tokens" prop_patternParserArbitraryTokensNoExceptions,+    named "no exceptions.decl parser accepts arbitrary tokens" prop_declParserArbitraryTokensNoExceptions,+    named "no exceptions.import decl parser accepts arbitrary tokens" prop_importDeclParserArbitraryTokensNoExceptions,+    named "no exceptions.module header parser accepts arbitrary tokens" prop_moduleHeaderParserArbitraryTokensNoExceptions+  ]+  where+    named :: (Testable prop) => String -> prop -> (String, Property)+    named name value = (name, property value)

@@ -20,7 +20,7 @@   ) where -import Aihc.Parser.Internal.Common (isConLikeName)+import Aihc.Parser.Internal.Common (isConLikeName, nameToUnqualified) import Aihc.Parser.Syntax import Data.Maybe (isJust, isNothing) import Data.Text (Text)@@ -37,7 +37,7 @@     | nameText name == "_" -> Right PWildcard     | isConLikeName name -> Right (PCon name [] [])     | isJust (nameQualifier name) -> Left "unexpected qualified name in pattern"-    | otherwise -> Right (PVar (mkUnqualifiedName (nameType name) (nameText name)))+    | otherwise -> Right (PVar (nameToUnqualified name))   ETypeSyntax form ty -> Right (PTypeSyntax form ty)   -- Parenthesized expression   -- When the inner expression is a view-pattern arrow (@expr -> expr@),

@@ -11,6 +11,10 @@     hiddenPragma,     optionalHiddenPragma,     moduleNameParser,+    nameToUnqualified,+    mkUnqualifiedNameAt,+    mkNameAt,+    identifierNameWithTokenParser,     identifierNameParser,     identifierUnqualifiedNameParser,     identifierTextParser,@@ -27,6 +31,7 @@     operatorTextParser,     constructorInfixOperatorNameParser,     stringTextParser,+    inputStartSpan,     withSpan,     withSpanAnn,     optionalSuffix,@@ -71,7 +76,7 @@  import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), closeImplicitLayoutContext) import Aihc.Parser.Syntax-import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken)+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, tokStreamExtensionSet) import Control.Monad (guard) import Data.Char (isUpper) import Data.Functor (($>))@@ -132,6 +137,7 @@ expectedTok expected =   tokenSatisfy (renderTokenKind expected) $ \tok ->     if lexTokenKind tok == expected then Just () else Nothing+{-# INLINE expectedTok #-}  -- | Match the end-of-file token. --@@ -224,6 +230,7 @@         if null expectedLabel           then MPE.EndOfInput           else MPE.Label (NE.fromList expectedLabel)+{-# INLINE tokenSatisfy #-}  hiddenPragma :: String -> (Pragma -> Maybe a) -> TokParser a hiddenPragma expectedLabel f = do@@ -267,22 +274,26 @@         TkQConId modName name | isModuleName (modName <> "." <> name) -> Just (modName <> "." <> name)         _ -> Nothing -identifierNameParser :: TokParser Name-identifierNameParser =+identifierNameWithTokenParser :: TokParser (LexToken, Name)+identifierNameWithTokenParser =   tokenSatisfy "identifier" $ \tok ->     case lexTokenKind tok of-      TkVarId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId ident))-      TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameConId ident))-      TkQVarId modName ident -> Just (mkName (Just modName) NameVarId ident)-      TkQConId modName ident -> Just (mkName (Just modName) NameConId ident)+      TkVarId ident -> Just (tok, qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId ident))+      TkConId ident -> Just (tok, qualifyName Nothing (mkUnqualifiedNameAt tok NameConId ident))+      TkQVarId modName ident -> Just (tok, mkNameAt tok (Just modName) NameVarId ident)+      TkQConId modName ident -> Just (tok, mkNameAt tok (Just modName) NameConId ident)       _ -> Nothing +identifierNameParser :: TokParser Name+identifierNameParser =+  snd <$> identifierNameWithTokenParser+ identifierUnqualifiedNameParser :: TokParser UnqualifiedName identifierUnqualifiedNameParser =   tokenSatisfy "unqualified identifier" $ \tok ->     case lexTokenKind tok of-      TkVarId ident -> Just (mkUnqualifiedName NameVarId ident)-      TkConId ident -> Just (mkUnqualifiedName NameConId ident)+      TkVarId ident -> Just (mkUnqualifiedNameAt tok NameVarId ident)+      TkConId ident -> Just (mkUnqualifiedNameAt tok NameConId ident)       _ -> Nothing  identifierTextParser :: TokParser Text@@ -312,33 +323,29 @@ constructorNameParser =   tokenSatisfy "constructor identifier" $ \tok ->     case lexTokenKind tok of-      TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameConId ident))-      TkQConId modName ident -> Just (mkName (Just modName) NameConId ident)+      TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId ident))+      TkQConId modName ident -> Just (mkNameAt tok (Just modName) NameConId ident)       _ -> Nothing  constructorUnqualifiedNameParser :: TokParser UnqualifiedName constructorUnqualifiedNameParser =   tokenSatisfy "unqualified constructor identifier" $ \tok ->     case lexTokenKind tok of-      TkConId ident -> Just (mkUnqualifiedName NameConId ident)+      TkConId ident -> Just (mkUnqualifiedNameAt tok NameConId ident)       _ -> Nothing  constructorOperatorUnqualifiedNameParser :: TokParser UnqualifiedName constructorOperatorUnqualifiedNameParser =   tokenSatisfy "unqualified constructor operator" $ \tok ->     case lexTokenKind tok of-      TkConSym op -> Just (mkUnqualifiedName NameConSym op)-      TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+      TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op)+      TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":")       _ -> Nothing  binderNameParser :: TokParser UnqualifiedName binderNameParser =-  spanned identifierUnqualifiedNameParser-    <|> parens (spanned operatorUnqualifiedNameParser)-  where-    spanned =-      withSpanAnn $ \sp name ->-        name {unqualifiedNameAnns = mkAnnotation sp : unqualifiedNameAnns name}+  identifierUnqualifiedNameParser+    <|> parens operatorUnqualifiedNameParser  recordFieldNameParser :: TokParser Name recordFieldNameParser =@@ -352,28 +359,28 @@ operatorNameParser =   tokenSatisfy "operator" $ \tok ->     case lexTokenKind tok of-      TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op))-      TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))-      TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op)-      TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)-      TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "@"))+      TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op))+      TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op))+      TkQVarSym modName op -> Just (mkNameAt tok (Just modName) NameVarSym op)+      TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op)+      TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "@"))       _ -> Nothing  operatorUnqualifiedNameParser :: TokParser UnqualifiedName operatorUnqualifiedNameParser =   tokenSatisfy "unqualified operator" $ \tok ->     case lexTokenKind tok of-      TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)-      TkConSym op -> Just (mkUnqualifiedName NameConSym op)-      TkReservedRightArrow -> Just (mkUnqualifiedName NameVarSym "->")-      TkReservedLeftArrow -> Just (mkUnqualifiedName NameVarSym "<-")-      TkReservedDoubleArrow -> Just (mkUnqualifiedName NameVarSym "=>")-      TkReservedEquals -> Just (mkUnqualifiedName NameVarSym "=")-      TkReservedPipe -> Just (mkUnqualifiedName NameVarSym "|")-      TkReservedDotDot -> Just (mkUnqualifiedName NameVarSym "..")-      TkReservedDoubleColon -> Just (mkUnqualifiedName NameVarSym "::")-      TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")-      TkReservedAt -> Just (mkUnqualifiedName NameVarSym "@")+      TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op)+      TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op)+      TkReservedRightArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "->")+      TkReservedLeftArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "<-")+      TkReservedDoubleArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "=>")+      TkReservedEquals -> Just (mkUnqualifiedNameAt tok NameVarSym "=")+      TkReservedPipe -> Just (mkUnqualifiedNameAt tok NameVarSym "|")+      TkReservedDotDot -> Just (mkUnqualifiedNameAt tok NameVarSym "..")+      TkReservedDoubleColon -> Just (mkUnqualifiedNameAt tok NameVarSym "::")+      TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":")+      TkReservedAt -> Just (mkUnqualifiedNameAt tok NameVarSym "@")       _ -> Nothing  -- | Parse an infix operator name (varop) for function definitions.@@ -390,17 +397,17 @@     symbolicOperatorParser =       tokenSatisfy "variable operator" $ \tok ->         case lexTokenKind tok of-          TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)+          TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op)           _ -> Nothing     backtickIdentifierParser = do       expectedTok TkSpecialBacktick-      op <- varIdTextParser+      op <- varIdNameParser       expectedTok TkSpecialBacktick-      pure (mkUnqualifiedName NameVarId op)-    varIdTextParser =+      pure op+    varIdNameParser =       tokenSatisfy "variable identifier" $ \tok ->         case lexTokenKind tok of-          TkVarId name -> Just name+          TkVarId name -> Just (mkUnqualifiedNameAt tok NameVarId name)           _ -> Nothing  -- | Parse an infix constructor operator name (conop) for pattern synonym where clauses.@@ -415,20 +422,32 @@     symbolicConstructorOperatorParser =       tokenSatisfy "constructor operator" $ \tok ->         case lexTokenKind tok of-          TkConSym op -> Just (mkUnqualifiedName NameConSym op)-          TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+          TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op)+          TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":")           _ -> Nothing     backtickConstructorIdentifierParser = do       expectedTok TkSpecialBacktick-      op <- constructorIdentifierTextParser+      op <- constructorIdentifierNameParser       expectedTok TkSpecialBacktick-      pure (mkUnqualifiedName NameConId op)-    constructorIdentifierTextParser =+      pure op+    constructorIdentifierNameParser =       tokenSatisfy "constructor identifier" $ \tok ->         case lexTokenKind tok of-          TkConId name -> Just name+          TkConId name -> Just (mkUnqualifiedNameAt tok NameConId name)           _ -> Nothing +mkUnqualifiedNameAt :: LexToken -> NameType -> Text -> UnqualifiedName+mkUnqualifiedNameAt tok ty txt =+  UnqualifiedName ty txt [mkAnnotation (lexTokenSpan tok)]++mkNameAt :: LexToken -> Maybe Text -> NameType -> Text -> Name+mkNameAt tok qualifier ty txt =+  Name qualifier ty txt [mkAnnotation (lexTokenSpan tok)]++nameToUnqualified :: Name -> UnqualifiedName+nameToUnqualified name =+  UnqualifiedName (nameType name) (nameText name) (nameAnns name)+ stringTextParser :: TokParser Text stringTextParser =   tokenSatisfy "string literal" $ \tok ->@@ -438,33 +457,35 @@  withSpanAnn :: (SourceSpan -> a -> a) -> TokParser a -> TokParser a withSpanAnn f parser = do-  ts <- fmap MP.stateInput MP.getParserState-  let startSpan-        | tokStreamEOFEmitted ts = noSourceSpan-        | tok : _ <- layoutBuffer (tokStreamLayoutState ts) = lexTokenSpan tok-        | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok-        | otherwise = noSourceSpan+  startInput <- MP.getInput   out <- parser-  lastToken <- fmap (tokStreamPrevToken . MP.stateInput) MP.getParserState-  let endSpan = maybe noSourceSpan lexTokenSpan lastToken+  endInput <- MP.getInput+  let startSpan = inputStartSpan startInput+      endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)       parserSpan = mergeSourceSpans startSpan endSpan   pure $ f parserSpan out+{-# INLINE withSpanAnn #-}  -- FIXME: Remove. withSpan :: TokParser (SourceSpan -> a) -> TokParser a withSpan parser = do-  ts <- fmap MP.stateInput MP.getParserState-  let startSpan-        | tokStreamEOFEmitted ts = noSourceSpan-        | tok : _ <- layoutBuffer (tokStreamLayoutState ts) = lexTokenSpan tok-        | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok-        | otherwise = noSourceSpan+  startInput <- MP.getInput   out <- parser-  lastToken <- fmap (tokStreamPrevToken . MP.stateInput) MP.getParserState-  let endSpan = maybe noSourceSpan lexTokenSpan lastToken+  endInput <- MP.getInput+  let startSpan = inputStartSpan startInput+      endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)       parserSpan = mergeSourceSpans startSpan endSpan   pure (out parserSpan)+{-# INLINE withSpan #-} +inputStartSpan :: TokStream -> SourceSpan+inputStartSpan ts+  | tokStreamEOFEmitted ts = noSourceSpan+  | tok : _ <- tokStreamBuffer ts = lexTokenSpan tok+  | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok+  | otherwise = noSourceSpan+{-# INLINE inputStartSpan #-}+ optionalSuffix :: TokParser b -> (a -> b -> a) -> TokParser a -> TokParser a optionalSuffix suffixParser attach parser = do   base <- parser@@ -638,8 +659,8 @@     constraintOperatorIdentifierParser =       tokenSatisfy "constraint operator identifier" $ \tok ->         case lexTokenKind tok of-          TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId name))-          TkConId name -> Just (qualifyName Nothing (mkUnqualifiedName NameConId name))+          TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name))+          TkConId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId name))           _ -> Nothing     unpromotedInfixOperatorParser =       tokenSatisfy "type infix operator" $ \tok ->@@ -647,11 +668,11 @@           TkVarSym op             | op /= "."                 && op /= "!" ->-                Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op), Unpromoted)-          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op), Unpromoted)+                Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op), Unpromoted)+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op), Unpromoted)           TkQVarSym modName op ->-            Just (mkName (Just modName) NameVarSym op, Unpromoted)-          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op, Unpromoted)+            Just (mkNameAt tok (Just modName) NameVarSym op, Unpromoted)+          TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op, Unpromoted)           _ -> Nothing     promotedInfixOperatorParser = do       expectedTok (TkVarSym "'")@@ -723,11 +744,46 @@ functionHeadParserWith = functionHeadParserWithBinder functionBinderNameParser infixOperatorNameParser  functionHeadParserWithBinder :: TokParser UnqualifiedName -> TokParser UnqualifiedName -> TokParser Pattern -> TokParser Pattern -> TokParser (MatchHeadForm, UnqualifiedName, [Pattern])-functionHeadParserWithBinder binderParser infixOpParser infixPatternParser prefixPatternParser =-  MP.try parenthesizedInfixHeadParser-    <|> MP.try infixHeadParser-    <|> prefixHeadParser+functionHeadParserWithBinder binderParser infixOpParser infixPatternParser prefixPatternParser = do+  (firstKind, secondKind) <-+    lookAhead $ do+      first <- lexTokenKind <$> anySingle+      second <- lexTokenKind <$> anySingle+      pure (first, second)+  case firstKind of+    TkVarId {}+      | startsPrefixHead secondKind -> prefixHeadParser+      | otherwise -> MP.try infixHeadParser <|> prefixHeadParser+    TkSpecialLParen ->+      MP.try parenthesizedInfixHeadParser+        <|> MP.try infixHeadParser+        <|> prefixHeadParser+    _ -> infixHeadParser   where+    startsPrefixHead kind =+      case kind of+        TkVarId {} -> True+        TkConId {} -> True+        TkQConId {} -> True+        TkInteger {} -> True+        TkFloat {} -> True+        TkChar {} -> True+        TkCharHash {} -> True+        TkString {} -> True+        TkStringHash {} -> True+        TkSpecialLParen -> True+        TkSpecialUnboxedLParen -> True+        TkSpecialLBracket -> True+        TkKeywordUnderscore -> True+        TkPrefixBang -> True+        TkPrefixTilde -> True+        TkPrefixMinus -> True+        TkQuasiQuote {} -> True+        TkTypeApp -> True+        TkReservedEquals -> True+        TkReservedPipe -> True+        _ -> False+     prefixHeadParser = do       name <- binderParser       pats <- MP.many prefixPatternParser@@ -755,13 +811,13 @@     variableIdentifierParser =       tokenSatisfy "function binder" $ \tok ->         case lexTokenKind tok of-          TkVarId ident -> Just (mkUnqualifiedName NameVarId ident)+          TkVarId ident -> Just (mkUnqualifiedNameAt tok NameVarId ident)           _ -> Nothing     variableOperatorParser =       tokenSatisfy "variable operator" $ \tok ->         case lexTokenKind tok of-          TkVarSym ident -> Just (mkUnqualifiedName NameVarSym ident)-          TkReservedAt -> Just (mkUnqualifiedName NameVarSym "@")+          TkVarSym ident -> Just (mkUnqualifiedNameAt tok NameVarSym ident)+          TkReservedAt -> Just (mkUnqualifiedNameAt tok NameVarSym "@")           _ -> Nothing  functionBindValue :: MatchHeadForm -> UnqualifiedName -> [Pattern] -> Rhs Expr -> ValueDecl@@ -798,9 +854,9 @@     Nothing -> False  isExtensionEnabled :: Extension -> TokParser Bool-isExtensionEnabled ext = do-  pst <- MP.getParserState-  pure (ext `elem` tokStreamExtensions (MP.stateInput pst))+isExtensionEnabled ext =+  memberExtension ext . tokStreamExtensionSet <$> MP.getInput+{-# INLINE isExtensionEnabled #-}  -- | Check whether any Template Haskell extension is enabled (quotes or full TH). thAnyEnabled :: TokParser Bool@@ -847,7 +903,19 @@   case closeImplicitLayoutContext (tokStreamLayoutState ts) of     Nothing -> pure False     Just laySt' -> do-      MP.updateParserState (\s -> s {MP.stateInput = (MP.stateInput s) {tokStreamLayoutState = laySt'}})+      let inserted = layoutBuffer laySt'+          laySt'' = laySt' {layoutBuffer = []}+      MP.updateParserState+        ( \s ->+            let input = MP.stateInput s+             in s+                  { MP.stateInput =+                      input+                        { tokStreamLayoutState = laySt'',+                          tokStreamBuffer = inserted <> tokStreamBuffer input+                        }+                  }+        )       pure True  -- | Like Megaparsec's 'MP.sepEndBy' but implements the parse-error rule for@@ -985,9 +1053,9 @@     sigOperatorParser =       tokenSatisfy "signature operator" $ \tok ->         case lexTokenKind tok of-          TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)-          TkConSym op -> Just (mkUnqualifiedName NameConSym op)-          TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")+          TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op)+          TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op)+          TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":")           _ -> Nothing  -- | Non-consuming lookahead: does the input start with @name \@@?@@ -1032,15 +1100,15 @@     symbolicOperatorParser =       tokenSatisfy "infix operator" $ \tok ->         case lexTokenKind tok of-          TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op))-          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))-          TkPrefixPercent -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "%"))-          TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op)-          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)+          TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op))+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op))+          TkPrefixPercent -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "%"))+          TkQVarSym modName op -> Just (mkNameAt tok (Just modName) NameVarSym op)+          TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op)           -- TkMinusOperator is minus when LexicalNegation is enabled but used as infix-          TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-"))+          TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "-"))           -- Reserved operators that can be used as infix operators-          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))           _ -> Nothing      backtickIdentifierOperatorParser =

@@ -45,16 +45,25 @@ ordinaryDeclParser :: TokParser Decl ordinaryDeclParser = do   (tok, nextTok) <- lookAhead ((,) <$> anySingle <*> anySingle)-  exprFallback <- exprDeclEnabled-  typeSigPrefix <- startsWithTypeSig   let tokKind = lexTokenKind tok       nextTokKind = lexTokenKind nextTok-      valueDecl-        | exprFallback = MP.try valueDeclParser <|> exprDeclParser-        | otherwise = valueDeclParser-      sigOrValueDecl-        | typeSigPrefix = typeSigOrPatternTypeSigDeclParser-        | otherwise = valueDecl+      valueDecl = do+        exprFallback <- exprDeclEnabled+        if exprFallback+          then MP.try valueDeclParser <|> exprDeclParser+          else valueDeclParser+      sigOrValueDecl = do+        typeSigPrefix <- startsWithTypeSig+        if typeSigPrefix+          then typeSigOrPatternTypeSigDeclParser+          else valueDecl+      fallbackDecl = do+        typeSigPrefix <- startsWithTypeSig+        exprFallback <- exprDeclEnabled+        (if typeSigPrefix then typeSigOrPatternTypeSigDeclParser else MP.empty)+          <|> MP.try valueDeclParser+          <|> patternBindDeclParser+          <|> (if exprFallback then exprDeclParser else MP.empty)   case tokKind of     TkKeywordData ->       case nextTokKind of@@ -86,11 +95,7 @@         TkSpecialComma -> sigOrValueDecl         TkReservedEquals -> valueDecl         _ -> nonBareVarPatternBindDeclParser <|> valueDecl-    _ ->-      (if typeSigPrefix then typeSigOrPatternTypeSigDeclParser else MP.empty)-        <|> MP.try valueDeclParser-        <|> patternBindDeclParser-        <|> (if exprFallback then exprDeclParser else MP.empty)+    _ -> fallbackDecl  -- | Like 'patternBindDeclParser' but rejects bare variable patterns. -- When the leading token is a variable identifier, a bare @x = 5@ must be@@ -607,10 +612,10 @@     symbolicOperatorParser =       tokenSatisfy "fixity operator" $ \tok ->         case lexTokenKind tok of-          TkVarSym op -> Just (mkUnqualifiedName NameVarSym op)-          TkConSym op -> Just (mkUnqualifiedName NameConSym op)-          TkReservedColon -> Just (mkUnqualifiedName NameConSym ":")-          TkReservedRightArrow -> Just (mkUnqualifiedName NameVarSym "->")+          TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op)+          TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op)+          TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":")+          TkReservedRightArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "->")           _ -> Nothing     backtickIdentifierParser = do       expectedTok TkSpecialBacktick@@ -1232,15 +1237,22 @@       pure (PrefixBinderHead name (params <> tailParams))  typeDeclHeadParser :: TokParser (BinderHead UnqualifiedName)-typeDeclHeadParser = declHeadParserWith (unqualifiedNameFromText <$> typeSynonymOperatorParser)+typeDeclHeadParser = declHeadParserWith typeSynonymOperatorParser -typeSynonymOperatorParser :: TokParser Text+typeSynonymOperatorParser :: TokParser UnqualifiedName typeSynonymOperatorParser =-  operatorTextParser <|> backtickTypeSynonymIdentifierParser+  symbolicTypeSynonymOperatorParser <|> backtickTypeSynonymIdentifierParser   where+    symbolicTypeSynonymOperatorParser =+      tokenSatisfy "type synonym operator" $ \tok ->+        case lexTokenKind tok of+          TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op)+          TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op)+          TkReservedAt -> Just (mkUnqualifiedNameAt tok NameVarSym "@")+          _ -> Nothing     backtickTypeSynonymIdentifierParser = do       expectedTok TkSpecialBacktick-      op <- identifierTextParser+      op <- identifierUnqualifiedNameParser       expectedTok TkSpecialBacktick       pure op @@ -1284,9 +1296,6 @@ classHeadParser :: TokParser (BinderHead UnqualifiedName) classHeadParser = declHeadParserWith (nameToUnqualified <$> typeFamilyOperatorParser) -nameToUnqualified :: Name -> UnqualifiedName-nameToUnqualified name = mkUnqualifiedName (nameType name) (nameText name)- binderHeadToTypeFamilyHead :: SourceSpan -> BinderHead UnqualifiedName -> (TypeHeadForm, Type, [TyVarBinder]) binderHeadToTypeFamilyHead span' binderHead =   case binderHead of@@ -1523,12 +1532,14 @@   symbolicConstructorOperatorParser <|> backtickConstructorIdentifierParser   where     symbolicConstructorOperatorParser =-      tokenSatisfy "constructor operator" $ \tok ->-        case lexTokenKind tok of-          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))-          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)-          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))-          _ -> Nothing+      (qualifyName Nothing <$> constructorOperatorUnqualifiedNameParser)+        <|> tokenSatisfy+          "qualified constructor operator"+          ( \tok ->+              case lexTokenKind tok of+                TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op)+                _ -> Nothing+          )     backtickConstructorIdentifierParser = do       expectedTok TkSpecialBacktick       op <- constructorNameParser@@ -1570,7 +1581,7 @@   constructorUnqualifiedNameParser     <|> do       op <- parens constructorOperatorParser-      pure (mkUnqualifiedName (nameType op) (nameText op))+      pure (nameToUnqualified op)  -- | Parse a pattern synonym declaration. -- Handles prefix, infix, and record forms with all three directionalities.@@ -1600,7 +1611,7 @@   lhs <- lowerIdentifierParser   op <- constructorOperatorParser   rhs <- lowerIdentifierParser-  pure (mkUnqualifiedName (nameType op) (nameText op), PatSynInfixArgs lhs rhs)+  pure (nameToUnqualified op, PatSynInfixArgs lhs rhs)  -- | Parse a record or prefix pattern synonym LHS. -- Record: @Con {field1, field2, ...}@

@@ -21,7 +21,7 @@ import Aihc.Parser.Internal.Type (typeAtomParser, typeParser, typeSignatureParser) import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax-import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken) import Control.Monad (guard) import Data.Functor (($>)) import Data.Text (Text)@@ -360,7 +360,8 @@  tokenExprParser :: String -> (LexToken -> Maybe Expr) -> TokParser Expr tokenExprParser expected matchToken =-  withSpanAnn (EAnn . mkAnnotation) (tokenSatisfy expected matchToken)+  tokenSatisfy expected $ \tok ->+    EAnn (mkAnnotation (lexTokenSpan tok)) <$> matchToken tok  charExprParser :: TokParser Expr charExprParser =@@ -394,11 +395,18 @@ -- | Shared application parser used by the report core and contextual -- variants.  The caller chooses the @aexp@-like atom parser. appExprParserWith :: TokParser Expr -> TokParser Expr-appExprParserWith atomParser = withSpanAnn (EAnn . mkAnnotation) $ do+appExprParserWith atomParser = do+  startInput <- MP.getInput   first <- atomParser   rest <- MP.many appArg-  pure $-    foldl applyArg first rest+  case rest of+    [] -> pure first+    _ -> do+      endInput <- MP.getInput+      let startSpan = inputStartSpan startInput+          endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)+          appSpan = mergeSourceSpans startSpan endSpan+      pure (EAnn (mkAnnotation appSpan) (foldl applyArg first rest))   where     appArg :: TokParser (Either Type Expr)     appArg = (Left <$> typeAppArg) <|> (Right <$> appExprArgParser)@@ -516,27 +524,10 @@ -- >      | aexp<qcon> '{' fbind_1 ',' ... ',' fbind_n '}' recordBaseAtomExprParserWith :: AtomContext -> TokParser Expr recordBaseAtomExprParserWith atomContext = do-  thAny <- thAnyEnabled   tok <- lookAhead anySingle   case lexTokenKind tok of     TkImplicitParam {} -> implicitParamExprParser-    _ ->-      MP.try (prefixNegateAtomExprParserWith atomContext)-        <|> MP.try parenOperatorExprParser-        <|> (if thAny then thQuoteExprParser else MP.empty)-        <|> (if thAny then thNameQuoteExprParser else MP.empty)-        <|> (if thAny then thTypedSpliceParser else MP.empty)-        <|> (if thAny then thUntypedSpliceParser else MP.empty)-        <|> quasiQuoteExprParser-        <|> parenExprParser-        <|> listExprParser-        <|> intExprParser-        <|> floatExprParser-        <|> charExprParser-        <|> stringExprParser-        <|> overloadedLabelExprParser-        <|> wildcardExprParser-        <|> varExprParser+    _ -> simpleAtomExprParserWith atomContext  -- | Parse an atom without record construction/update syntax. --@@ -549,42 +540,69 @@  atomExprParserWith :: AtomContext -> TokParser Expr atomExprParserWith atomContext = do-  blockArgsEnabled <- isExtensionEnabled BlockArguments-  thAny <- thAnyEnabled-  explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces-  requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments   tok <- lookAhead anySingle   case lexTokenKind tok of     TkImplicitParam {} -> implicitParamExprParser-    TkKeywordType-      | explicitNamespacesEnabled || requiredTypeArgumentsEnabled -> explicitTypeExprParser+    TkKeywordType -> do+      explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces+      requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments+      if explicitNamespacesEnabled || requiredTypeArgumentsEnabled+        then explicitTypeExprParser+        else simpleAtomExprParserWith atomContext     TkReservedBackslash -> lambdaExprParser-    TkKeywordLet -> letExprParser-    TkKeywordDo | blockArgsEnabled -> doExprParser-    TkKeywordMdo | blockArgsEnabled -> mdoExprParser-    TkQualifiedDo {} | blockArgsEnabled -> qualifiedDoExprParser-    TkQualifiedMdo {} | blockArgsEnabled -> qualifiedMdoExprParser-    TkKeywordCase | blockArgsEnabled -> caseExprParser-    TkKeywordIf | blockArgsEnabled -> ifExprParser-    TkKeywordProc | blockArgsEnabled && atomContext == NormalExprAtom -> procExprParser-    _ ->-      MP.try (prefixNegateAtomExprParserWith atomContext)-        <|> MP.try parenOperatorExprParser-        <|> (if thAny then thQuoteExprParser else MP.empty)-        <|> (if thAny then thNameQuoteExprParser else MP.empty)-        <|> (if thAny then thTypedSpliceParser else MP.empty)-        <|> (if thAny then thUntypedSpliceParser else MP.empty)-        <|> quasiQuoteExprParser-        <|> parenExprParser-        <|> listExprParser-        <|> intExprParser-        <|> floatExprParser-        <|> charExprParser-        <|> stringExprParser-        <|> overloadedLabelExprParser-        <|> wildcardExprParser-        <|> varExprParser+    TkKeywordLet -> blockAtom letExprParser+    TkKeywordDo -> blockAtom doExprParser+    TkKeywordMdo -> blockAtom mdoExprParser+    TkQualifiedDo {} -> blockAtom qualifiedDoExprParser+    TkQualifiedMdo {} -> blockAtom qualifiedMdoExprParser+    TkKeywordCase -> blockAtom caseExprParser+    TkKeywordIf -> blockAtom ifExprParser+    TkKeywordProc+      | atomContext == NormalExprAtom -> blockAtom procExprParser+    _ -> simpleAtomExprParserWith atomContext+  where+    blockAtom parser = do+      blockArgsEnabled <- isExtensionEnabled BlockArguments+      if blockArgsEnabled+        then parser+        else simpleAtomExprParserWith atomContext +simpleAtomExprParserWith :: AtomContext -> TokParser Expr+simpleAtomExprParserWith atomContext = do+  tok <- lookAhead anySingle+  case lexTokenKind tok of+    TkPrefixMinus -> prefixNegateAtomExprParserWith atomContext+    TkSpecialLParen -> MP.try parenOperatorExprParser <|> parenExprParser+    TkSpecialUnboxedLParen -> parenExprParser+    TkSpecialLBracket -> listExprParser+    TkInteger {} -> intExprParser+    TkFloat {} -> floatExprParser+    TkChar {} -> charExprParser+    TkCharHash {} -> charExprParser+    TkString {} -> stringExprParser+    TkStringHash {} -> stringExprParser+    TkOverloadedLabel {} -> overloadedLabelExprParser+    TkKeywordUnderscore -> wildcardExprParser+    TkVarId {} -> varExprParser+    TkConId {} -> varExprParser+    TkQVarId {} -> varExprParser+    TkQConId {} -> varExprParser+    TkQuasiQuote {} -> quasiQuoteExprParser+    TkTHExpQuoteOpen -> thAtom thQuoteExprParser+    TkTHTypedQuoteOpen -> thAtom thQuoteExprParser+    TkTHDeclQuoteOpen -> thAtom thQuoteExprParser+    TkTHTypeQuoteOpen -> thAtom thQuoteExprParser+    TkTHPatQuoteOpen -> thAtom thQuoteExprParser+    TkTHQuoteTick -> thAtom thNameQuoteExprParser+    TkTHTypeQuoteTick -> thAtom thNameQuoteExprParser+    TkTHTypedSplice -> thAtom thTypedSpliceParser+    TkTHSplice -> thAtom thUntypedSpliceParser+    _ -> varExprParser+  where+    thAtom parser = do+      thAny <- thAnyEnabled+      if thAny then parser else varExprParser+ explicitTypeExprParser :: TokParser Expr explicitTypeExprParser = withSpanAnn (EAnn . mkAnnotation) $ do   expectedTok TkKeywordType@@ -633,20 +651,20 @@ operatorExprNameParser =   tokenSatisfy "operator" $ \tok ->     case lexTokenKind tok of-      TkVarSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym))-      TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym))-      TkQVarSym modName sym -> Just (mkName (Just modName) NameVarSym sym)-      TkQConSym modName sym -> Just (mkName (Just modName) NameConSym sym)-      TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "@"))-      TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-"))-      TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))-      TkReservedDoubleColon -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "::"))-      TkReservedEquals -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "="))-      TkReservedPipe -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "|"))-      TkReservedLeftArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "<-"))-      TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "->"))-      TkReservedDoubleArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "=>"))-      TkReservedDotDot -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym ".."))+      TkVarSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym))+      TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym))+      TkQVarSym modName sym -> Just (mkNameAt tok (Just modName) NameVarSym sym)+      TkQConSym modName sym -> Just (mkNameAt tok (Just modName) NameConSym sym)+      TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "@"))+      TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "-"))+      TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))+      TkReservedDoubleColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "::"))+      TkReservedEquals -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "="))+      TkReservedPipe -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "|"))+      TkReservedLeftArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "<-"))+      TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "->"))+      TkReservedDoubleArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "=>"))+      TkReservedDotDot -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym ".."))       _ -> Nothing  rhsParser :: TokParser (Rhs Expr)@@ -1297,17 +1315,31 @@       )  varExprParser :: TokParser Expr-varExprParser = withSpanAnn (EAnn . mkAnnotation) $ do-  EVar <$> identifierNameParser+varExprParser = do+  (tok, name) <- identifierNameWithTokenParser+  pure (EAnn (mkAnnotation (lexTokenSpan tok)) (EVar name))  implicitParamExprParser :: TokParser Expr-implicitParamExprParser = withSpanAnn (EAnn . mkAnnotation) $ do-  EVar . qualifyName Nothing . mkUnqualifiedName NameVarId <$> implicitParamNameParser+implicitParamExprParser =+  tokenSatisfy "implicit parameter" $ \tok ->+    case lexTokenKind tok of+      TkImplicitParam name ->+        Just $+          EAnn+            (mkAnnotation (lexTokenSpan tok))+            (EVar (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name)))+      _ -> Nothing  wildcardExprParser :: TokParser Expr-wildcardExprParser = withSpanAnn (EAnn . mkAnnotation) $ do-  expectedTok TkKeywordUnderscore-  pure (EVar (qualifyName Nothing (mkUnqualifiedName NameVarId "_")))+wildcardExprParser =+  tokenSatisfy "wildcard" $ \tok ->+    case lexTokenKind tok of+      TkKeywordUnderscore ->+        Just $+          EAnn+            (mkAnnotation (lexTokenSpan tok))+            (EVar (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId "_")))+      _ -> Nothing  -- | Parse Template Haskell quote brackets thQuoteExprParser :: TokParser Expr

@@ -15,9 +15,9 @@ import Aihc.Parser.Internal.Common import {-# SOURCE #-} Aihc.Parser.Internal.Expr (atomExprParser, exprParser) import Aihc.Parser.Internal.Type (typeParser)-import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenText)+import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax-import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken)+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken) import Text.Megaparsec (anySingle, lookAhead, (<|>)) import Text.Megaparsec qualified as MP @@ -71,9 +71,9 @@     symbolicConOp =       tokenSatisfy "constructor operator" $ \tok ->         case lexTokenKind tok of-          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op))-          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op)-          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op))+          TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op)+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))           _ -> Nothing     backtickConOp =       MP.try $@@ -185,61 +185,83 @@ numericLiteralParser = intLiteralParser <|> floatLiteralParser  wildcardPatternParser :: TokParser Pattern-wildcardPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do-  expectedTok TkKeywordUnderscore-  pure PWildcard+wildcardPatternParser =+  tokenSatisfy "wildcard" $ \tok ->+    case lexTokenKind tok of+      TkKeywordUnderscore -> Just (PAnn (mkAnnotation (lexTokenSpan tok)) PWildcard)+      _ -> Nothing  literalPatternParser :: TokParser Pattern-literalPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do-  PLit <$> literalParser+literalPatternParser =+  tokenSatisfy "literal" $ \tok -> do+    lit <- literalFromToken tok+    let ann = mkAnnotation (lexTokenSpan tok)+    pure (PAnn ann (PLit (LitAnn ann lit)))  quasiQuotePatternParser :: TokParser Pattern-quasiQuotePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do-  (quoter, body) <- tokenSatisfy "quasi quote" $ \tok ->+quasiQuotePatternParser =+  tokenSatisfy "quasi quote" $ \tok ->     case lexTokenKind tok of-      TkQuasiQuote q b -> Just (q, b)+      TkQuasiQuote quoter body -> Just (PAnn (mkAnnotation (lexTokenSpan tok)) (PQuasiQuote quoter body))       _ -> Nothing-  pure (PQuasiQuote quoter body)  literalParser :: TokParser Literal literalParser = intLiteralParser <|> floatLiteralParser <|> charLiteralParser <|> stringLiteralParser  tokenLiteralParser :: String -> (LexToken -> Maybe Literal) -> TokParser Literal tokenLiteralParser expected matchToken =-  withSpanAnn (LitAnn . mkAnnotation) (tokenSatisfy expected matchToken)+  tokenSatisfy expected $ \tok ->+    LitAnn (mkAnnotation (lexTokenSpan tok)) <$> matchToken tok +literalFromToken :: LexToken -> Maybe Literal+literalFromToken tok =+  intLiteralFromToken tok+    <|> floatLiteralFromToken tok+    <|> charLiteralFromToken tok+    <|> stringLiteralFromToken tok+ intLiteralParser :: TokParser Literal intLiteralParser =-  tokenLiteralParser "integer literal" $ \tok ->-    case lexTokenKind tok of-      TkInteger i nt -> Just (LitInt i nt (lexTokenText tok))-      _ -> Nothing+  tokenLiteralParser "integer literal" intLiteralFromToken +intLiteralFromToken :: LexToken -> Maybe Literal+intLiteralFromToken tok =+  case lexTokenKind tok of+    TkInteger i nt -> Just (LitInt i nt (lexTokenText tok))+    _ -> Nothing+ floatLiteralParser :: TokParser Literal floatLiteralParser =-  tokenLiteralParser "floating literal" $ \tok ->-    case lexTokenKind tok of-      TkFloat x ft -> Just (LitFloat x ft (lexTokenText tok))-      _ -> Nothing+  tokenLiteralParser "floating literal" floatLiteralFromToken +floatLiteralFromToken :: LexToken -> Maybe Literal+floatLiteralFromToken tok =+  case lexTokenKind tok of+    TkFloat x ft -> Just (LitFloat x ft (lexTokenText tok))+    _ -> Nothing+ charLiteralParser :: TokParser Literal-charLiteralParser = withSpanAnn (LitAnn . mkAnnotation) $ do-  (ctor, c, repr) <- tokenSatisfy "character literal" $ \tok ->-    case lexTokenKind tok of-      TkChar x -> Just (LitChar, x, lexTokenText tok)-      TkCharHash x txt -> Just (LitCharHash, x, txt)-      _ -> Nothing-  pure (ctor c repr)+charLiteralParser =+  tokenLiteralParser "character literal" charLiteralFromToken +charLiteralFromToken :: LexToken -> Maybe Literal+charLiteralFromToken tok =+  case lexTokenKind tok of+    TkChar x -> Just (LitChar x (lexTokenText tok))+    TkCharHash x txt -> Just (LitCharHash x txt)+    _ -> Nothing+ stringLiteralParser :: TokParser Literal-stringLiteralParser = withSpanAnn (LitAnn . mkAnnotation) $ do-  (ctor, s, repr) <- tokenSatisfy "string literal" $ \tok ->-    case lexTokenKind tok of-      TkString x -> Just (LitString, x, lexTokenText tok)-      TkStringHash x txt -> Just (LitStringHash, x, txt)-      _ -> Nothing-  pure (ctor s repr)+stringLiteralParser =+  tokenLiteralParser "string literal" stringLiteralFromToken +stringLiteralFromToken :: LexToken -> Maybe Literal+stringLiteralFromToken tok =+  case lexTokenKind tok of+    TkString x -> Just (LitString x (lexTokenText tok))+    TkStringHash x txt -> Just (LitStringHash x txt)+    _ -> Nothing+ -- | Parse Template Haskell pattern splice: $pat or $(pat) thSplicePatternParser :: TokParser Pattern thSplicePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do@@ -266,19 +288,24 @@           )  varOrConPatternParser :: TokParser Pattern-varOrConPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do-  name <- identifierNameParser+varOrConPatternParser = do+  (tok, name) <- identifierNameWithTokenParser   mNextTok <- MP.optional (lookAhead anySingle)+  let ann = mkAnnotation (lexTokenSpan tok)   case mNextTok of     Just nextTok       | isConLikeName name && lexTokenKind nextTok == TkSpecialLBrace -> do           (fields, hasWildcard) <- braces recordPatternFieldListParser-          pure (PRecord name fields hasWildcard)+          endInput <- MP.getInput+          let endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput)+              recordSpan = mergeSourceSpans (lexTokenSpan tok) endSpan+          pure (PAnn (mkAnnotation recordSpan) (PRecord name fields hasWildcard))     _ ->       pure $-        if isConLikeName name-          then PCon name [] []-          else PVar (mkUnqualifiedName (nameType name) (nameText name))+        PAnn ann $+          if isConLikeName name+            then PCon name [] []+            else PVar (nameToUnqualified name)  recordFieldPatternParser :: TokParser (RecordField Pattern) recordFieldPatternParser = do@@ -290,7 +317,7 @@       pure (RecordField field pat False)     Nothing -> do       -- NamedFieldPuns: just "field" means "field = field"-      pure (RecordField field (PVar (mkUnqualifiedName (nameType field) (nameText field))) True)+      pure (RecordField field (PVar (nameToUnqualified field)) True)  -- | Parse the contents of record pattern braces, supporting RecordWildCards ".." recordPatternFieldListParser :: TokParser ([RecordField Pattern], Bool)@@ -443,14 +470,15 @@          -- Parse an operator token as a variable or constructor pattern.         operatorPatternParser :: TokParser Pattern-        operatorPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do+        operatorPatternParser = do           tok' <- anySingle+          let ann = mkAnnotation (lexTokenSpan tok')           case lexTokenKind tok' of-            TkVarSym op -> pure (PVar (mkUnqualifiedName NameVarSym op))-            TkConSym op -> pure (PCon (qualifyName Nothing (mkUnqualifiedName NameConSym op)) [] [])-            TkQConSym modName op -> pure (PCon (mkName (Just modName) NameConSym op) [] [])-            TkReservedColon -> pure (PCon (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) [] [])-            TkReservedAt -> pure (PVar (mkUnqualifiedName NameVarSym "@"))+            TkVarSym op -> pure (PAnn ann (PVar (mkUnqualifiedNameAt tok' NameVarSym op)))+            TkConSym op -> pure (PAnn ann (PCon (qualifyName Nothing (mkUnqualifiedNameAt tok' NameConSym op)) [] []))+            TkQConSym modName op -> pure (PAnn ann (PCon (mkNameAt tok' (Just modName) NameConSym op) [] []))+            TkReservedColon -> pure (PAnn ann (PCon (qualifyName Nothing (mkUnqualifiedNameAt tok' NameConSym ":")) [] []))+            TkReservedAt -> pure (PAnn ann (PVar (mkUnqualifiedNameAt tok' NameVarSym "@")))             _ ->               MP.customFailure                 UnexpectedTokenExpecting

@@ -0,0 +1,22 @@+-- | Internal parser entry points used by generative tests.+--+-- This module is exposed so the test-only @fuzz@ component can exercise the+-- token parsers compiled into the main library. It is not a stable public API.+module Aihc.Parser.Internal.Testing+  ( LexToken (..),+    LexTokenKind (..),+    TokenOrigin (..),+    lexModuleTokens,+    lexTokens,+    parseDeclFromTokens,+    parseExprFromTokens,+    parseImportDeclFromTokens,+    parseModuleFromTokens,+    parseModuleHeaderFromTokens,+    parsePatternFromTokens,+    parseTypeFromTokens,+  )+where++import Aihc.Parser.Internal.FromTokens+import Aihc.Parser.Lex

@@ -261,15 +261,15 @@     unpromotedInfixOperatorParser =       tokenSatisfy "type infix operator" $ \tok ->         case lexTokenKind tok of-          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Unpromoted)+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"), Unpromoted)           TkVarSym op             | op /= "."                 && op /= "!"                 && op /= "'" ->-                Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op), Unpromoted)-          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op), Unpromoted)-          TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op, Unpromoted)-          TkQConSym modName op -> Just (mkName (Just modName) NameConSym op, Unpromoted)+                Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op), Unpromoted)+          TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op), Unpromoted)+          TkQVarSym modName op -> Just (mkNameAt tok (Just modName) NameVarSym op, Unpromoted)+          TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op, Unpromoted)           _ -> Nothing      backtickTypeOperatorParser = MP.try $ do@@ -281,10 +281,10 @@     typeOperatorIdentifierParser =       tokenSatisfy "type operator identifier" $ \tok ->         case lexTokenKind tok of-          TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId name))-          TkConId name -> Just (qualifyName Nothing (mkUnqualifiedName NameConId name))-          TkQVarId modName name -> Just (mkName (Just modName) NameVarId name)-          TkQConId modName name -> Just (mkName (Just modName) NameConId name)+          TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name))+          TkConId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId name))+          TkQVarId modName name -> Just (mkNameAt tok (Just modName) NameVarId name)+          TkQConId modName name -> Just (mkNameAt tok (Just modName) NameConId name)           _ -> Nothing      promotedInfixOperatorParser = MP.try $ do@@ -294,13 +294,13 @@       -- or ':$$: for a promoted user-defined type operator)       tokenSatisfy "promoted type infix operator" $ \tok ->         case lexTokenKind tok of-          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Promoted)+          TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"), Promoted)           TkVarSym sym             | sym /= "." && sym /= "!" ->-                Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym), Promoted)-          TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym), Promoted)-          TkQVarSym modQual sym -> Just (mkName (Just modQual) NameVarSym sym, Promoted)-          TkQConSym modQual sym -> Just (mkName (Just modQual) NameConSym sym, Promoted)+                Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym), Promoted)+          TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym), Promoted)+          TkQVarSym modQual sym -> Just (mkNameAt tok (Just modQual) NameVarSym sym, Promoted)+          TkQConSym modQual sym -> Just (mkNameAt tok (Just modQual) NameConSym sym, Promoted)           _ -> Nothing  -- | Report core:@@ -368,25 +368,40 @@ -- This parser also admits extension atoms such as promoted types, -- quasi-quotes, splices, wildcards, and implicit-parameter types. typeAtomParser :: TokParser Type-typeAtomParser = do-  thAny <- thAnyEnabled-  ipEnabled <- isExtensionEnabled ImplicitParams-  MP.try promotedTypeParser-    <|> typeLiteralTypeParser-    <|> typeQuasiQuoteParser-    <|> (if thAny then thSpliceTypeParser else MP.empty)-    <|> (if ipEnabled then typeImplicitParamParser else MP.empty)-    <|> typeListParser-    <|> MP.try typeParenOperatorParser-    <|> typeParenOrTupleParser-    <|> typeStarParser-    <|> typeWildcardParser-    <|> typeIdentifierParser+typeAtomParser = typeAtomParserByToken  typeSignatureAtomParser :: TokParser Type-typeSignatureAtomParser = do-  thAny <- thAnyEnabled-  ipEnabled <- isExtensionEnabled ImplicitParams+typeSignatureAtomParser = typeAtomParserByToken++typeAtomParserByToken :: TokParser Type+typeAtomParserByToken = do+  tok <- MP.lookAhead MP.anySingle+  case lexTokenKind tok of+    TkInteger {} -> typeLiteralTypeParser+    TkString {} -> typeLiteralTypeParser+    TkChar {} -> typeLiteralTypeParser+    TkQuasiQuote {} -> typeQuasiQuoteParser+    TkTHSplice -> do+      thAny <- thAnyEnabled+      if thAny then thSpliceTypeParser else typeAtomParserAlternatives False False+    TkImplicitParam {} -> do+      ipEnabled <- isExtensionEnabled ImplicitParams+      if ipEnabled then typeImplicitParamParser else typeAtomParserAlternatives False False+    TkSpecialLBracket -> typeListParser+    TkSpecialLParen -> MP.try typeParenOperatorParser <|> typeParenOrTupleParser+    TkSpecialUnboxedLParen -> typeParenOrTupleParser+    TkKeywordUnderscore -> typeWildcardParser+    TkVarId {} -> typeIdentifierParser+    TkConId {} -> typeIdentifierParser+    TkQVarId {} -> typeIdentifierParser+    TkQConId {} -> typeIdentifierParser+    _ -> do+      thAny <- thAnyEnabled+      ipEnabled <- isExtensionEnabled ImplicitParams+      typeAtomParserAlternatives thAny ipEnabled++typeAtomParserAlternatives :: Bool -> Bool -> TokParser Type+typeAtomParserAlternatives thAny ipEnabled =   MP.try promotedTypeParser     <|> typeLiteralTypeParser     <|> typeQuasiQuoteParser@@ -412,19 +427,20 @@   TImplicitParam name <$> typeSignatureParser  typeWildcardParser :: TokParser Type-typeWildcardParser = withSpanAnn (TAnn . mkAnnotation) $ do-  expectedTok TkKeywordUnderscore-  pure TWildcard+typeWildcardParser =+  tokenSatisfy "wildcard" $ \tok ->+    case lexTokenKind tok of+      TkKeywordUnderscore -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) TWildcard)+      _ -> Nothing  typeLiteralTypeParser :: TokParser Type-typeLiteralTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do-  lit <- tokenSatisfy "type literal" $ \tok ->+typeLiteralTypeParser =+  tokenSatisfy "type literal" $ \tok ->     case lexTokenKind tok of-      TkInteger n _ -> Just (TypeLitInteger n (lexTokenText tok))-      TkString s -> Just (TypeLitSymbol s (lexTokenText tok))-      TkChar c -> Just (TypeLitChar c (lexTokenText tok))+      TkInteger n _ -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TTypeLit (TypeLitInteger n (lexTokenText tok))))+      TkString s -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TTypeLit (TypeLitSymbol s (lexTokenText tok))))+      TkChar c -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TTypeLit (TypeLitChar c (lexTokenText tok))))       _ -> Nothing-  pure (TTypeLit lit)  promotedTypeParser :: TokParser Type promotedTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do@@ -441,13 +457,13 @@   unicodeSyntax <- isExtensionEnabled UnicodeSyntax   op <- tokenSatisfy "type operator" $ \tok ->     case lexTokenKind tok of-      TkVarSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym))-      TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym))-      TkQVarSym modQual sym -> Just (mkName (Just modQual) NameVarSym sym)-      TkQConSym modQual sym -> Just (mkName (Just modQual) NameConSym sym)+      TkVarSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym))+      TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym))+      TkQVarSym modQual sym -> Just (mkNameAt tok (Just modQual) NameVarSym sym)+      TkQConSym modQual sym -> Just (mkNameAt tok (Just modQual) NameConSym sym)       -- Handle reserved operators that can be used as type constructors-      TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "->"))-      TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"))+      TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "->"))+      TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))       -- Note: ~ is now lexed as TkVarSym "~" so TkVarSym case handles it       _ -> Nothing   expectedTok TkSpecialRParen@@ -465,27 +481,26 @@       _ -> Nothing  typeIdentifierParser :: TokParser Type-typeIdentifierParser = withSpanAnn (TAnn . mkAnnotation) $ do-  name <- identifierNameParser+typeIdentifierParser = do+  (tok, name) <- identifierNameWithTokenParser   pure $-    case (nameQualifier name, nameType name, T.uncons (nameText name)) of-      (Nothing, NameVarId, Just (c, _))-        | isLower c || c == '_' ->-            TVar (mkUnqualifiedName NameVarId (nameText name))-      _ -> TCon name Unpromoted+    TAnn (mkAnnotation (lexTokenSpan tok)) $+      case (nameQualifier name, nameType name, T.uncons (nameText name)) of+        (Nothing, NameVarId, Just (c, _))+          | isLower c || c == '_' ->+              TVar (nameToUnqualified name)+        _ -> TCon name Unpromoted  typeStarParser :: TokParser Type-typeStarParser = withSpanAnn (TAnn . mkAnnotation) $ do+typeStarParser = do   starIsType <- isExtensionEnabled StarIsType   unicodeSyntax <- isExtensionEnabled UnicodeSyntax   if starIsType-    then do-      spelling <- tokenSatisfy "star kind" $ \tok ->-        case lexTokenKind tok of-          TkVarSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (lexTokenText tok)-          TkConSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (lexTokenText tok)-          _ -> Nothing-      pure (TStar spelling)+    then tokenSatisfy "star kind" $ \tok ->+      case lexTokenKind tok of+        TkVarSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TStar (lexTokenText tok)))+        TkConSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TStar (lexTokenText tok)))+        _ -> Nothing     else MP.empty  isStarTypeSymbol :: Bool -> Bool -> T.Text -> Bool

@@ -71,10 +71,8 @@ import Aihc.Parser.Lex.Types import Aihc.Parser.Syntax import Control.Applicative ((<|>))-import Data.Char (GeneralCategory (..), generalCategory, isAscii, isAsciiLower, isAsciiUpper, isDigit)+import Data.Char (GeneralCategory (..), generalCategory, isAscii, isAsciiLower, isAsciiUpper, isDigit, ord) import Data.Maybe (fromMaybe, isJust)-import Data.Set (Set)-import Data.Set qualified as Set import Data.Text (Text, pattern Empty, pattern (:<)) import Data.Text qualified as T @@ -735,27 +733,31 @@  lexSymbol :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState) lexSymbol env st =-  firstTextKind st symbols+  case lexerInput st of+    '(' :< ('#' :< _)+      | hasUnboxed -> Just (emitToken st "(#" TkSpecialUnboxedLParen)+    '#' :< (')' :< _)+      | hasUnboxed -> Just (emitToken st "#)" TkSpecialUnboxedRParen)+    '(' :< ('|' :< rest)+      | hasArrows,+        bananaOpenAllowed rest ->+          Just (emitToken st "(|" TkBananaOpen)+    '(' :< _ -> Just (emitToken st "(" TkSpecialLParen)+    ')' :< _ -> Just (emitToken st ")" TkSpecialRParen)+    '[' :< _ -> Just (emitToken st "[" TkSpecialLBracket)+    ']' :< _ -> Just (emitToken st "]" TkSpecialRBracket)+    '{' :< _ -> Just (emitToken st "{" TkSpecialLBrace)+    '}' :< _ -> Just (emitToken st "}" TkSpecialRBrace)+    ',' :< _ -> Just (emitToken st "," TkSpecialComma)+    ';' :< _ -> Just (emitToken st ";" TkSpecialSemicolon)+    '`' :< _ -> Just (emitToken st "`" TkSpecialBacktick)+    _ -> Nothing   where-    symbols =-      ( if hasExt UnboxedTuples env || hasExt UnboxedSums env-          then [("(#", TkSpecialUnboxedLParen), ("#)", TkSpecialUnboxedRParen)]-          else []-      )-        <> [("(|", TkBananaOpen) | hasExt Arrows env, bananaOpenAllowed]-        <> [ ("(", TkSpecialLParen),-             (")", TkSpecialRParen),-             ("[", TkSpecialLBracket),-             ("]", TkSpecialRBracket),-             ("{", TkSpecialLBrace),-             ("}", TkSpecialRBrace),-             (",", TkSpecialComma),-             (";", TkSpecialSemicolon),-             ("`", TkSpecialBacktick)-           ]+    hasUnboxed = hasExt UnboxedTuples env || hasExt UnboxedSums env+    hasArrows = hasExt Arrows env -    bananaOpenAllowed =-      case T.drop 2 (lexerInput st) of+    bananaOpenAllowed rest =+      case rest of         c :< _ -> not (isSymbolicOpChar c)         _ -> True @@ -818,8 +820,7 @@             Right (body, _) ->               let raw = "\"\"\"" <> body <> "\"\"\""                   decoded = T.pack (processMultilineString (T.unpack body))-                  (tokTxt, tokKind, st') =-                    withOptionalMagicHashSuffix 1 env st raw (TkString decoded) (TkStringHash decoded)+                  (tokTxt, tokKind, st') = lexStringKind env st raw decoded                in Just (mkToken st st' tokTxt tokKind, st')             Left raw ->               let full = "\"\"\"" <> raw@@ -832,8 +833,7 @@                 Right (body, _) ->                   let rawT = "\"" <> body <> "\""                       decoded = fromMaybe body (decodeStringBody body)-                      (tokTxt, tokKind, st') =-                        withOptionalMagicHashSuffix 1 env st rawT (TkString decoded) (TkStringHash decoded)+                      (tokTxt, tokKind, st') = lexStringKind env st rawT decoded                    in Just (mkToken st st' tokTxt tokKind, st')                 Left raw ->                   let full = "\"" <> raw@@ -841,6 +841,14 @@                    in Just (mkErrorToken st st' full "unterminated string literal", st')             _ -> Nothing +lexStringKind :: LexerEnv -> LexerState -> Text -> Text -> (Text, LexTokenKind, LexerState)+lexStringKind env st raw decoded =+  case withOptionalMagicHashSuffix 1 env st raw (TkString decoded) (TkStringHash decoded) of+    (tokTxt, TkStringHash _ _, st')+      | T.any ((>= 256) . ord) decoded ->+          (tokTxt, TkError "primitive string literal contains a character outside Latin-1", st')+    result -> result+ lexQuasiQuote :: LexerState -> Maybe (LexToken, LexerState) lexQuasiQuote st =   case lexerInput st of@@ -1024,7 +1032,7 @@     c :< _ -> isSymbolicOpChar c     _ -> False -keywordTokenKind :: Set Extension -> Text -> Maybe LexTokenKind+keywordTokenKind :: ExtensionSet -> Text -> Maybe LexTokenKind keywordTokenKind exts txt =   case txt of     "case" -> Just TkKeywordCase@@ -1051,12 +1059,12 @@     "type" -> Just TkKeywordType     "where" -> Just TkKeywordWhere     "_" -> Just TkKeywordUnderscore-    "proc" | Set.member Arrows exts -> Just TkKeywordProc-    "rec" | Set.member Arrows exts || Set.member RecursiveDo exts -> Just TkKeywordRec-    "mdo" | Set.member RecursiveDo exts -> Just TkKeywordMdo-    "pattern" | Set.member PatternSynonyms exts -> Just TkKeywordPattern-    "by" | Set.member TransformListComp exts -> Just TkKeywordBy-    "using" | Set.member TransformListComp exts -> Just TkKeywordUsing+    "proc" | memberExtension Arrows exts -> Just TkKeywordProc+    "rec" | memberExtension Arrows exts || memberExtension RecursiveDo exts -> Just TkKeywordRec+    "mdo" | memberExtension RecursiveDo exts -> Just TkKeywordMdo+    "pattern" | memberExtension PatternSynonyms exts -> Just TkKeywordPattern+    "by" | memberExtension TransformListComp exts -> Just TkKeywordBy+    "using" | memberExtension TransformListComp exts -> Just TkKeywordUsing     _ -> Nothing  reservedOpTokenKind :: Text -> Maybe LexTokenKind

@@ -451,6 +451,7 @@                 layoutBuffer = []               }        in (preInserted <> pendingInserted <> bolInserted <> [tok], stNext)+{-# INLINE layoutTransition #-}  closeImplicitLayoutContext :: LayoutState -> Maybe LayoutState closeImplicitLayoutContext st =

@@ -74,12 +74,9 @@ -- We intentionally recognize string gaps here so a gap-closing backslash does -- not incorrectly escape the following quote. consumedEscapeTail :: Text -> Maybe Int-consumedEscapeTail rest =-  if T.null rest-    then Nothing-    else do-      (_, rest') <- parseEscape rest-      pure (T.length rest - T.length rest')+consumedEscapeTail rest = do+  (_, _, consumed) <- parseEscapeWithLength rest+  pure consumed  -- | Decode the body of a Haskell string literal (content between the quotes, -- without the surrounding @\"@ characters) natively on 'Text', avoiding the@@ -107,60 +104,66 @@ isOctDigit c = c >= '0' && c <= '7'  parseEscape :: Text -> Maybe (Maybe Char, Text)-parseEscape t = case T.uncons t of+parseEscape = fmap (\(decoded, rest, _) -> (decoded, rest)) . parseEscapeWithLength++parseEscapeWithLength :: Text -> Maybe (Maybe Char, Text, Int)+parseEscapeWithLength t = case T.uncons t of   Nothing -> Nothing   Just (c, rest) -> case c of-    'a' -> Just (Just '\a', rest)-    'b' -> Just (Just '\b', rest)-    'f' -> Just (Just '\f', rest)-    'n' -> Just (Just '\n', rest)-    'r' -> Just (Just '\r', rest)-    't' -> Just (Just '\t', rest)-    'v' -> Just (Just '\v', rest)-    '\\' -> Just (Just '\\', rest)-    '"' -> Just (Just '"', rest)-    '\'' -> Just (Just '\'', rest)-    '&' -> Just (Nothing, rest) -- empty escape+    'a' -> consumedOne (Just '\a') rest+    'b' -> consumedOne (Just '\b') rest+    'f' -> consumedOne (Just '\f') rest+    'n' -> consumedOne (Just '\n') rest+    'r' -> consumedOne (Just '\r') rest+    't' -> consumedOne (Just '\t') rest+    'v' -> consumedOne (Just '\v') rest+    '\\' -> consumedOne (Just '\\') rest+    '"' -> consumedOne (Just '"') rest+    '\'' -> consumedOne (Just '\'') rest+    '&' -> consumedOne Nothing rest -- empty escape     '^' -> case T.uncons rest of -- control character \^X       Just (cc, rest')         | cc >= '@' && cc <= '_' ->-            Just (Just (chr (ord cc - 64)), rest')+            Just (Just (chr (ord cc - 64)), rest', 2)       _ -> Nothing     'x' ->       -- hex escape \xNN  (use Integer to prevent Int overflow on long inputs)       let (digits, rest') = T.span isHexDigit rest        in if T.null digits             then Nothing-            else decodeNumericEscape 16 digits rest'+            else decodeNumericEscape 16 1 digits rest'     'o' ->       -- octal escape \oNN  (use Integer to prevent Int overflow on long inputs)       let (digits, rest') = T.span isOctDigit rest        in if T.null digits             then Nothing-            else decodeNumericEscape 8 digits rest'+            else decodeNumericEscape 8 1 digits rest'     _       | isDigit c -> -- decimal escape \NNN  (use Integer to prevent Int overflow on long inputs)           let (moreDigits, rest') = T.span isDigit rest               digits = T.cons c moreDigits-           in decodeNumericEscape 10 digits rest'+           in decodeNumericEscape 10 0 digits rest'       | isSpace c -> -- gap escape \ whitespace \-          let rest' = T.dropWhile isSpace rest+          let (spaces, rest') = T.span isSpace rest            in case T.uncons rest' of-                Just ('\\', rest'') -> Just (Nothing, rest'')+                Just ('\\', rest'') -> Just (Nothing, rest'', 2 + T.length spaces)                 _ -> Nothing-      | otherwise -> parseNamedEscape t+      | otherwise -> parseNamedEscapeWithLength t   where-    decodeNumericEscape :: Integer -> Text -> Text -> Maybe (Maybe Char, Text)-    decodeNumericEscape !base digits rest' =+    consumedOne decoded rest' = Just (decoded, rest', 1)++    decodeNumericEscape :: Integer -> Int -> Text -> Text -> Maybe (Maybe Char, Text, Int)+    decodeNumericEscape !base prefixLength digits rest' =       let n = T.foldl' (\a d -> a * base + toInteger (digitToInt d)) (0 :: Integer) digits-       in if n > 0x10FFFF then Nothing else Just (Just (chr (fromIntegral n)), rest')+          consumed = prefixLength + T.length digits+       in if n > 0x10FFFF then Nothing else Just (Just (chr (fromIntegral n)), rest', consumed) -parseNamedEscape :: Text -> Maybe (Maybe Char, Text)-parseNamedEscape t = foldr tryMatch Nothing namedEscapeTable+parseNamedEscapeWithLength :: Text -> Maybe (Maybe Char, Text, Int)+parseNamedEscapeWithLength t = foldr tryMatch Nothing namedEscapeTable   where     tryMatch (name, ch) fallback =       case T.stripPrefix name t of-        Just rest -> Just (Just ch, rest)+        Just rest -> Just (Just ch, rest, T.length name)         Nothing -> fallback  -- Named ASCII escape sequences per the Haskell 2010 report.

@@ -51,8 +51,6 @@ import Control.DeepSeq (NFData) import Data.Char (GeneralCategory (..), generalCategory, isAscii, isSpace, ord) import Data.Data (Data)-import Data.Set (Set)-import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic)@@ -215,12 +213,13 @@   deriving (Eq, Ord, Show, Generic, NFData)  newtype LexerEnv = LexerEnv-  { lexerExtensions :: Set Extension+  { lexerExtensions :: ExtensionSet   }   deriving (Eq, Show)  hasExt :: Extension -> LexerEnv -> Bool-hasExt ext env = Set.member ext (lexerExtensions env)+hasExt ext env = memberExtension ext (lexerExtensions env)+{-# INLINE hasExt #-}  data LexerState = LexerState   { lexerInput :: !Text,@@ -316,7 +315,7 @@   deriving (Eq, Show)  mkLexerEnv :: [Extension] -> LexerEnv-mkLexerEnv exts = LexerEnv {lexerExtensions = Set.fromList exts}+mkLexerEnv exts = LexerEnv {lexerExtensions = mkExtensionSet exts}  mkInitialLexerState :: FilePath -> [Extension] -> Text -> (LexerEnv, LexerState) mkInitialLexerState sourceName exts input =

@@ -1367,6 +1367,10 @@ needsCompTransformParens :: Expr -> Bool needsCompTransformParens = \case   EAnn _ sub -> needsCompTransformParens sub+  -- Transform-list contextual parsers terminate an if-expression before the+  -- following @by@ or @using@ keyword. Parenthesizing it is not only+  -- unnecessary: GHC preserves the grouping in its parsed fingerprint.+  EIf {} -> False   ETypeSig {} -> True   EParen {} -> False   EInfix _ _ rhs -> needsCompTransformInfixRhsParens rhs

@@ -44,7 +44,6 @@     hang,     hardline,     hsep,-    indent,     nest,     nesting,     parens,@@ -75,7 +74,7 @@   | otherwise = pretty raw  prettySpliceBody :: Expr -> Doc ann-prettySpliceBody = nest 2 . prettyExpr+prettySpliceBody = prettyExpr  -- | Pretty instance for Module - renders to valid Haskell source code. instance Pretty Module where@@ -297,7 +296,7 @@     RoleInfer -> "_"  prettyValueDeclLines :: ValueDecl -> [Doc ann]-prettyValueDeclLines valueDecl = map (nest 2) $+prettyValueDeclLines valueDecl =   case valueDecl of     PatternBind multTag pat rhs -> [prettyMultiplicityTag multTag <> prettyPattern pat <+> prettyRhs rhs]     FunctionBind name matches ->@@ -319,14 +318,13 @@ -- | Pretty-print a pattern synonym declaration. prettyPatSynDecl :: PatSynDecl -> Doc ann prettyPatSynDecl ps =-  hang 2 $-    hsep-      ( ["pattern"]-          <> prettyPatSynLhs (patSynDeclName ps) (patSynDeclArgs ps)-          <> [dirArrow (patSynDeclDir ps)]-          <> [prettyPattern (patSynDeclPat ps)]-          <> prettyPatSynWhere (patSynDeclName ps) (patSynDeclDir ps)-      )+  hsep+    ( ["pattern"]+        <> prettyPatSynLhs (patSynDeclName ps) (patSynDeclArgs ps)+        <> [dirArrow (patSynDeclDir ps)]+        <> [prettyPattern (patSynDeclPat ps)]+        <> prettyPatSynWhere (patSynDeclName ps) (patSynDeclDir ps)+    )   where     dirArrow PatSynBidirectional = "="     dirArrow PatSynUnidirectional = "<-"@@ -347,19 +345,23 @@ prettyPatSynWhere _ PatSynUnidirectional = [] prettyPatSynWhere _ (PatSynExplicitBidirectional []) = ["where", spacedBraces mempty] prettyPatSynWhere name (PatSynExplicitBidirectional matches) =-  ["where" <> hardline <> indent 2 (vsep (map (prettyFunctionMatch name) matches))]+  ["where" <> nest 2 (hardline <> vsep (map (prettyFunctionMatch name) matches))]  prettyFunctionMatchLines :: UnqualifiedName -> Match -> [Doc ann] prettyFunctionMatchLines name match =   case matchRhs match of     UnguardedRhs {} -> [prettyFunctionMatch name match]     GuardedRhss _ grhss mWhereDecls ->-      prettyFunctionHead name (matchHeadForm match) (matchPats match)-        : map-          (indent 2)-          ( map prettyGuardedRhsBlock grhss-              <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls]-          )+      [ prettyFunctionHead name (matchHeadForm match) (matchPats match)+          <> nest+            2+            ( hardline+                <> vsep+                  ( map prettyGuardedRhsBlock grhss+                      <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls]+                  )+            )+      ]  prettyFunctionMatch :: UnqualifiedName -> Match -> Doc ann prettyFunctionMatch name match =@@ -385,34 +387,27 @@   case rhs of     UnguardedRhs _ body whereDecls ->       "="-        <+> nest 4 (prettyExpr body)+        <+> prettyExpr body         <> prettyIndentedWhereClause whereDecls     GuardedRhss _ guards whereDecls ->-      hardline <> indent 2 (prettyGuardedRhssBlock guards whereDecls)+      nest 2 (hardline <> prettyGuardedRhssBlock guards whereDecls)  prettyWhereClauseBare :: Maybe [Decl] -> Doc ann prettyWhereClauseBare Nothing = mempty prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty prettyWhereClauseBare (Just decls) =-  "where" <> hardline <> indent 2 (vsep (concatMap prettyDeclLines decls))+  "where" <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls))  prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann prettyIndentedWhereClause Nothing = mempty-prettyIndentedWhereClause whereDecls = hardline <> indent 2 (prettyWhereClauseBare whereDecls)+prettyIndentedWhereClause whereDecls = nest 2 (hardline <> prettyWhereClauseBare whereDecls)  prettyTHDeclQuote :: [Decl] -> Doc ann-prettyTHDeclQuote [] =-  hang 2 $-    "[d|"-      <> hardline-      <> "|]"+prettyTHDeclQuote [] = "[d| |]" prettyTHDeclQuote decls =-  hang 2 $-    "[d|"-      <> hardline-      <> vsep (concatMap prettyDeclLines decls)-      <> hardline-      <> "|]"+  "[d|"+    <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls))+    <+> "|]"  -- | Infix type-family heads use @l \`Op\` r@ with a 'NameConId' operator (e.g. -- @\`And\`@), so 'isSymbolicTypeName' is false; 'TypeHeadInfix' already marks@@ -555,7 +550,7 @@     PCon con typeArgs args -> hsep ([prettyPrefixName con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)     PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs     PView viewExpr inner ->-      prettyExpr viewExpr <> hardline <> indent 1 ("->" <+> prettyPattern inner)+      prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyPattern inner)     PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner     PStrict inner -> "!" <> prettyPattern inner     PIrrefutable inner -> "~" <> prettyPattern inner@@ -664,8 +659,7 @@ prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann prettyGadtConBlock ctors derivingClauses =   "where"-    <> hardline-    <> indent 2 (vsep (map prettyDataCon ctors <> derivingParts derivingClauses))+    <> nest 2 (hardline <> vsep (map prettyDataCon ctors <> derivingParts derivingClauses))  derivingPart :: DerivingClause -> [Doc ann] derivingPart (DerivingClause strategy classes) =@@ -858,8 +852,7 @@         items ->           headDoc             <+> "where"-            <> hardline-            <> indent 2 (vsep (concatMap prettyClassItemLines items))+            <> nest 2 (hardline <> vsep (concatMap prettyClassItemLines items))  prettyClassFundeps :: [FunctionalDependency] -> [Doc ann] prettyClassFundeps deps =@@ -931,8 +924,7 @@         items ->           headDoc             <+> "where"-            <> hardline-            <> indent 2 (vsep (concatMap prettyInstanceItemLines items))+            <> nest 2 (hardline <> vsep (concatMap prettyInstanceItemLines items))  prettyStandaloneDeriving :: StandaloneDerivingDecl -> Doc ann prettyStandaloneDeriving decl =@@ -1150,13 +1142,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\n  (x\n   + 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 ->-      prettyExpr fn <> hardline <> " " <> prettyTypeAppArg ty+      nest 2 (prettyExpr fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty)     EVar name -> prettyName name     ETypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty     ETypeSyntax TypeSyntaxInTerm ty -> prettyType ty@@ -1178,25 +1170,25 @@     ETHSplice body -> "$" <> prettySpliceBody body     ETHTypedSplice body -> "$$" <> prettySpliceBody body     EIf cond yes no ->-      "if" <+> nest 2 (prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no)+      "if" <+> prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no     EMultiWayIf rhss ->-      "if" <+> hang 3 (prettyMultiWayIfRhss rhss)+      "if" <+> align (prettyMultiWayIfRhss rhss)     ELambdaPats pats body ->-      "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> nest 2 (prettyExpr body)+      "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyExpr body     ELambdaCase alts ->       "\\" <> "case" <> prettyCaseLayout (map prettyCaseAlt alts)     ELambdaCases alts ->       "\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts)     EInfix lhs op rhs ->-      prettyExpr lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs+      nest 2 (prettyExpr lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs)     ENegate inner -> "-" <+> prettyExprAtStatementStart inner     ESectionL lhs op ->-      prettyExpr lhs <> hardline <> " " <> prettyNameInfixOp op+      nest 2 (prettyExpr lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op)     ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs     ELetDecls decls body ->       case decls of         [] -> prettyLetDecls decls <+> "in" <+> prettyExpr body-        _ -> align (prettyLetDecls decls <> hardline <> indent 2 ("in" <+> prettyExpr body))+        _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyExpr body))     ECase scrutinee alts ->       prettyCaseExpr prettyCaseLayout scrutinee alts     EDo stmts flavor ->@@ -1225,10 +1217,10 @@     EGetFieldProjection fields ->       "." <> mconcat (punctuate "." (map prettyName fields))     ETypeSig inner ty ->-      align (prettyExpr inner <> hardline <> "::" <+> prettyType ty)+      nest 2 (prettyExpr inner) <> nest 1 (hardline <> "::" <+> prettyType ty)     EParen inner -> case inner of       ECase scrutinee alts ->-        parens (prettyCaseExpr prettyCaseLayoutAligned scrutinee alts)+        parens (prettyCaseExpr prettyCaseLayout scrutinee alts)       -- ESectionR with a '#'-starting op renders as "(# ...)" which the lexer       -- reads as TkSpecialUnboxedLParen when UnboxedTuples/UnboxedSums is on.       -- A leading space produces "( # ...)" which is unambiguous.@@ -1246,7 +1238,7 @@       let slots = [if i == altIdx then prettyExpr inner else mempty | i <- [0 .. arity - 1]]        in hsep ["(#", prettyBarSeparated slots, "#)"]     EProc pat body ->-      "proc" <+> prettyPattern pat <+> "->" <+> nest 2 (prettyCmd body)+      "proc" <+> prettyPattern pat <+> "->" <+> prettyCmd body     EPragma pragma inner ->       prettyPragma pragma <+> prettyExpr inner     EAnn _ sub -> prettyExpr sub@@ -1257,7 +1249,7 @@ prettyAppWith :: (Expr -> Doc ann) -> Expr -> Doc ann prettyAppWith prettyFn expr =   let (fn, args) = flattenApps expr-   in vsep (prettyFn fn : map (indent 2 . prettyExpr) args)+   in prettyFn fn <> nest 2 (hardline <> vsep (map prettyExpr args))   where     flattenApps = go []     go args (EAnn _ sub) = go args sub@@ -1268,13 +1260,13 @@ prettyCommaSeparated render items =   case map render items of     [] -> mempty-    rendered -> hang 2 (vsep (punctuate comma rendered))+    rendered -> hsep (punctuate comma rendered)  prettyBarSeparated :: [Doc ann] -> Doc ann prettyBarSeparated items =   case items of     [] -> mempty-    firstItem : restItems -> hang 2 (vsep (firstItem : map ("|" <+>) restItems))+    firstItem : restItems -> hang 1 (vsep (firstItem : map ("|" <+>) restItems))  prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann prettyTupleBody tupleFlavor inner =@@ -1289,18 +1281,15 @@     else prettyName (recordFieldName field) <+> "=" <+> prettyExpr (recordFieldValue field)  prettyCaseAltWith :: (body -> Doc ann) -> CaseAlt body -> Doc ann-prettyCaseAltWith prettyBody (CaseAlt _ pat rhs) = nest 2 $+prettyCaseAltWith prettyBody (CaseAlt _ pat rhs) =   case rhs of     UnguardedRhs _ body whereDecls ->       prettyPattern pat         <+> "->"-        <> hardline-        <> indent 2 (prettyBody body)+        <+> nest 2 (prettyBody body)         <> prettyIndentedWhereClause whereDecls     GuardedRhss _ grhss whereDecls ->-      prettyPattern pat-        <> hardline-        <> indent 2 (vsep (map (prettyCaseGuardedRhsBlock prettyBody) grhss))+      prettyGuardedCaseAlt (prettyPattern pat) prettyBody grhss         <> prettyIndentedWhereClause whereDecls  prettyCaseAlt :: CaseAlt Expr -> Doc ann@@ -1315,8 +1304,7 @@         <> hardline         <> " "         <> pretty arrow-        <> hardline-        <> indent 2 (prettyExpr body)+        <+> prettyExpr body  prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann prettyCaseGuardedRhsBlock prettyBody grhs =@@ -1327,9 +1315,16 @@         <> hardline         <> " "         <> "->"-        <> hardline-        <> indent 2 (prettyBody body)+        <+> nest 2 (prettyBody body) +prettyGuardedCaseAlt :: Doc ann -> (body -> Doc ann) -> [GuardedRhs body] -> Doc ann+prettyGuardedCaseAlt headDoc prettyBody grhss =+  case map (prettyCaseGuardedRhsBlock prettyBody) grhss of+    [] -> headDoc+    [firstGrhs] -> headDoc <+> firstGrhs+    firstGrhs : restGrhss ->+      headDoc <+> firstGrhs <> nest 2 (hardline <> vsep restGrhss)+ prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann prettyMultiWayIfRhss rhss = vsep (map (prettyGuardedRhsBodyBlock "->") rhss) @@ -1337,13 +1332,14 @@ prettyGuardQualifiersLayout qualifiers =   case map prettyGuardQualifier qualifiers of     [] -> mempty+    [firstQualifier] -> firstQualifier     firstQualifier : restQualifiers ->-      vsep (firstQualifier : map (indent 2 . (comma <+>)) restQualifiers)+      firstQualifier <> nest 2 (hardline <> vsep (map (comma <+>) restQualifiers))  prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann prettyCaseExpr layout scrutinee alts =   "case"-    <+> nest 2 (prettyExpr scrutinee)+    <+> align (prettyExpr scrutinee)     <+> "of"     <> layout (map prettyCaseAlt alts) @@ -1351,23 +1347,16 @@ prettyCaseLayout [] = " " <> spacedBraces mempty prettyCaseLayout alts = nest 2 (hardline <> vsep alts) -prettyCaseLayoutAligned :: [Doc ann] -> Doc ann-prettyCaseLayoutAligned [] = " " <> spacedBraces mempty-prettyCaseLayoutAligned alts = hang 2 (hardline <> vsep alts)- prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann-prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) = nest 2 $+prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) =   case rhs of     UnguardedRhs _ body whereDecls ->       hsep (map prettyPattern pats)         <+> "->"-        <> hardline-        <> indent 2 (prettyExpr body)+        <+> nest 2 (prettyExpr body)         <> prettyIndentedWhereClause whereDecls     GuardedRhss _ grhss whereDecls ->-      hsep (map prettyPattern pats)-        <> hardline-        <> indent 2 (vsep (map (prettyCaseGuardedRhsBlock prettyExpr) grhss))+      prettyGuardedCaseAlt (hsep (map prettyPattern pats)) prettyExpr grhss         <> prettyIndentedWhereClause whereDecls  prettyGuardQualifier :: GuardQualifier -> Doc ann@@ -1382,7 +1371,7 @@ prettyLetDecls decls   | null decls = "let" <+> spacedBraces mempty   | otherwise =-      "let" <+> hang 0 (vsep (concatMap prettyDeclLines decls))+      "let" <+> align (vsep (concatMap prettyDeclLines decls))  prettyDoFlavor :: DoFlavor -> Doc ann prettyDoFlavor DoPlain = "do"@@ -1406,10 +1395,10 @@ prettyDoStmt stmt =   case stmt of     DoAnn _ inner -> prettyDoStmt inner-    DoBind pat expr -> prettyPattern pat <+> "<-" <+> nest 2 (prettyExpr expr)+    DoBind pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr     DoLetDecls decls -> prettyLetDecls decls     ---    DoExpr expr -> hang 2 (prettyExprAtStatementStart expr)+    DoExpr expr -> prettyExprAtStatementStart expr     DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyDoStmt stmts)  -- prettyExprAtStatementStart is a hack to get overloaded labels to align. We always print a space before labels which messes things up.@@ -1419,10 +1408,10 @@     EAnn _ sub -> prettyExprAtStatementStart sub     EOverloadedLabel _ raw -> pretty raw     EApp {} -> prettyAppWith prettyExprAtStatementStart expr-    ETypeApp fn ty -> prettyExprAtStatementStart fn <> hardline <> " " <> prettyTypeAppArg ty-    EInfix lhs op rhs -> prettyExprAtStatementStart lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs-    ESectionL lhs op -> prettyExprAtStatementStart lhs <> hardline <> " " <> prettyNameInfixOp op-    ETypeSig inner ty -> prettyExprAtStatementStart inner <> hardline <> indent 2 ("::" <+> prettyType ty)+    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)     ERecordUpd base fields ->       prettyExprAtStatementStart base <+> braces (hsep (punctuate comma (map prettyBinding fields)))     EGetField base field ->@@ -1432,16 +1421,16 @@ -- | Pretty-print an arrow command. prettyCmd :: Cmd -> Doc ann prettyCmd (CmdAnn _ inner) = prettyCmd inner-prettyCmd cmd = nest 2 $+prettyCmd cmd =   case cmd of     CmdArrApp lhs HsFirstOrderApp rhs ->       prettyExpr lhs <+> "-<" <+> prettyExpr rhs     CmdArrApp lhs HsHigherOrderApp rhs ->       prettyExpr lhs <+> "-<<" <+> prettyExpr rhs     CmdInfix l op r ->-      prettyCmd l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r+      nest 2 (prettyCmd l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r)     CmdDo stmts ->-      "do" <> prettyDoLayout prettyCmdStmt stmts+      "do" <> nest 2 (prettyDoLayout prettyCmdStmt stmts)     CmdIf cond yes no ->       "if" <+> prettyExpr cond <+> "then" <+> prettyCmd yes <+> "else" <+> prettyCmd no     CmdCase scrut alts ->@@ -1449,7 +1438,7 @@     CmdLet decls body ->       case decls of         [] -> prettyLetDecls decls <+> "in" <+> prettyCmd body-        _ -> align (prettyLetDecls decls <> hardline <> "in" <+> prettyCmd body)+        _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyCmd body))     CmdLam pats body ->       "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyCmd body     CmdApp c e ->@@ -1468,7 +1457,7 @@     DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyCmdStmt stmts)  prettyCmdAtStatementStart :: Cmd -> Doc ann-prettyCmdAtStatementStart cmd = nest 2 $+prettyCmdAtStatementStart cmd =   case cmd of     CmdAnn _ inner -> prettyCmdAtStatementStart inner     CmdArrApp lhs HsFirstOrderApp rhs ->@@ -1476,7 +1465,7 @@     CmdArrApp lhs HsHigherOrderApp rhs ->       prettyExprAtStatementStart lhs <+> "-<<" <+> prettyExpr rhs     CmdInfix l op r ->-      prettyCmdAtStatementStart l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r+      nest 2 (prettyCmdAtStatementStart l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r)     CmdApp c e ->       prettyCmdAtStatementStart c <+> prettyExpr e     _ -> prettyCmd cmd@@ -1508,13 +1497,9 @@   let guards = guardedRhsGuards grhs       body = guardedRhsBody grhs    in "|"-        <+> nest-          2-          ( prettyGuardQualifiersLayout guards-              <> hardline-              <> "="-              <+> nest 2 (prettyExpr body)-          )+        <+> prettyGuardQualifiersLayout guards+        <+> "="+        <+> prettyExpr body  prettyArithSeq :: ArithSeq -> Doc ann prettyArithSeq seqInfo =@@ -1553,7 +1538,7 @@       ["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity]     eqsPart Nothing = []     eqsPart (Just []) = ["where", spacedBraces mempty]-    eqsPart (Just eqs) = ["where" <> hardline <> indent 2 (vsep (map prettyTypeFamilyEq eqs))]+    eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> vsep (map prettyTypeFamilyEq eqs))]  prettyTypeFamilyEq :: TypeFamilyEq -> Doc ann prettyTypeFamilyEq eq =

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}  -- |@@ -34,6 +35,7 @@     DoStmt (..),     Expr (..),     Extension (..),+    ExtensionSet,     ExtensionSetting (..),     ExportSpec (..),     IEEntityNamespace (..),@@ -112,6 +114,8 @@     binderHeadParams,     effectiveExtensions,     extensionName,+    memberExtension,+    mkExtensionSet,     extensionSettingName,     gadtBodyResultType,     languageEditionExtensions,@@ -156,16 +160,19 @@ where  import Control.DeepSeq (NFData (..))+import Data.Bits (setBit, testBit) import Data.Char (GeneralCategory (..), generalCategory) import Data.Data (Constr, Data (..), DataType, Fixity (Prefix), mkConstr, mkDataType) import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn) import Data.List (sort)+import Data.List qualified as List import Data.Map qualified as Map import Data.Maybe (fromMaybe, mapMaybe) import Data.String (IsString (..)) import Data.Text (Text) import Data.Text qualified as T import Data.Typeable (cast)+import Data.Word (Word64) import GHC.Generics (Generic)  -- | A @LANGUAGE@ pragma name.@@ -332,6 +339,29 @@   | XmlSyntax   deriving (Data, Eq, Ord, Show, Read, Enum, Bounded, Generic, NFData) +data ExtensionSet = ExtensionSet !Word64 !Word64 !Word64+  deriving stock (Eq, Show, Generic)+  deriving anyclass (NFData)++mkExtensionSet :: [Extension] -> ExtensionSet+mkExtensionSet = List.foldl' insertExtension (ExtensionSet 0 0 0)+  where+    insertExtension (ExtensionSet low middle high) ext =+      case fromEnum ext `quotRem` 64 of+        (0, bit) -> ExtensionSet (setBit low bit) middle high+        (1, bit) -> ExtensionSet low (setBit middle bit) high+        (2, bit) -> ExtensionSet low middle (setBit high bit)+        _ -> error "mkExtensionSet: extension enum exceeds bitset capacity"++memberExtension :: Extension -> ExtensionSet -> Bool+memberExtension ext (ExtensionSet low middle high) =+  case fromEnum ext `quotRem` 64 of+    (0, bit) -> testBit low bit+    (1, bit) -> testBit middle bit+    (2, bit) -> testBit high bit+    _ -> False+{-# INLINE memberExtension #-}+ -- | A single @LANGUAGE@ pragma entry. -- Examples: @EnableExtension LambdaCase@ for @{-# LANGUAGE LambdaCase #-}@ and -- @DisableExtension ImplicitPrelude@ for @{-# LANGUAGE NoImplicitPrelude #-}@.@@ -709,7 +739,7 @@     NameVarSym   | -- | Constructor operator (e.g., @:@, @:++@)     NameConSym-  deriving (Eq, Show, Generic, NFData, Enum, Bounded, Data)+  deriving (Eq, Show, Read, Generic, NFData, Enum, Bounded, Data)  mkName :: Maybe Text -> NameType -> Text -> Name mkName qualifier ty txt = Name qualifier ty txt []@@ -1844,7 +1874,7 @@     InfixL   | -- | @infixr@     InfixR-  deriving (Data, Eq, Show, Generic, NFData)+  deriving (Data, Eq, Show, Read, Generic, NFData)  -- | A foreign import or export declaration. -- Example: @foreign import ccall "puts" puts :: CString -> IO CInt@.@@ -1910,19 +1940,30 @@   deriving (Data, Eq, Show, Generic, NFData)  -- | Opaque metadata attached to syntax nodes.--- Example: a stored 'SourceSpan' created with 'mkAnnotation'.-newtype Annotation = Annotation Dynamic+--+-- Parsed syntax overwhelmingly attaches 'SourceSpan' annotations, so spans get+-- a direct representation. Later compiler stages can still attach arbitrary+-- typed metadata through the dynamic fallback.+data Annotation+  = SourceSpanAnnotation !SourceSpan+  | DynamicAnnotation Dynamic   deriving (Show, Generic)  mkAnnotation :: (Typeable a) => a -> Annotation-mkAnnotation = Annotation . toDyn+mkAnnotation value =+  case cast value of+    Just span' -> SourceSpanAnnotation span'+    Nothing -> DynamicAnnotation (toDyn value)+{-# INLINE mkAnnotation #-}  fromAnnotation :: (Typeable a) => Annotation -> Maybe a-fromAnnotation (Annotation value) = fromDynamic value+fromAnnotation (SourceSpanAnnotation span') = cast span'+fromAnnotation (DynamicAnnotation value) = fromDynamic value+{-# INLINE fromAnnotation #-}  instance Data Annotation where   gfoldl _ z = z-  gunfold _ z _ = z (Annotation (toDyn ()))+  gunfold _ z _ = z (SourceSpanAnnotation NoSourceSpan)   toConstr _ = annotationConstr   dataTypeOf _ = annotationDataType @@ -1936,7 +1977,8 @@   _ == _ = True  instance NFData Annotation where-  rnf (Annotation _) = ()+  rnf (SourceSpanAnnotation span') = rnf span'+  rnf (DynamicAnnotation _) = ()  -- | An expression. data Expr

@@ -29,7 +29,7 @@     readModuleHeaderExtensions,     scanAllTokens,   )-import Aihc.Parser.Syntax (Extension, SourceSpan, applyExtensionSetting, applyImpliedExtensions)+import Aihc.Parser.Syntax (Extension, ExtensionSet, SourceSpan, applyExtensionSetting, applyImpliedExtensions, mkExtensionSet) import Control.DeepSeq (NFData (..)) import Data.Text (Text) import Data.Text qualified as T@@ -81,14 +81,16 @@ data TokStream = TokStream   { -- | Shared lazy list of raw tokens (never re-scanned on backtrack).     tokStreamRawTokens :: [LexToken],-    -- | Layout engine state (context stack, pending layout, buffer).+    -- | Layout engine state (context stack and pending layout).     tokStreamLayoutState :: LayoutState,+    -- | Tokens ready for the parser, including virtual layout tokens.+    tokStreamBuffer :: [LexToken],     -- | Hidden pragmas that appeared before the next source token.     -- Parsers may inspect these explicitly, but they never participate in the     -- ordinary token stream.     tokStreamPendingPragmas :: [Pragma],     tokStreamPrevToken :: Maybe LexToken,-    tokStreamExtensions :: [Extension],+    tokStreamExtensionSet :: ExtensionSet,     -- | Whether this stream has already emitted TkEOF.     -- After EOF is emitted, 'take1_' returns Nothing.     tokStreamEOFEmitted :: !Bool@@ -118,8 +120,8 @@       <> show (length (tokStreamPendingPragmas ts))       <> ", prevToken = "       <> show (tokStreamPrevToken ts)-      <> ", extensions = "-      <> show (tokStreamExtensions ts)+      <> ", extensionSet = "+      <> show (tokStreamExtensionSet ts)       <> " }"  -- Manual NFData instance — don't force the lazy raw token list.@@ -127,7 +129,7 @@   rnf ts =     rnf (tokStreamPendingPragmas ts) `seq`       rnf (tokStreamPrevToken ts) `seq`-        rnf (tokStreamExtensions ts) `seq`+        rnf (tokStreamExtensionSet ts) `seq`           rnf (tokStreamEOFEmitted ts)  -- | Create a TokStream for parsing expressions/declarations (no module layout).@@ -138,9 +140,10 @@         TokStream           { tokStreamRawTokens = scanAllTokens env lexSt,             tokStreamLayoutState = mkInitialLayoutState False exts,+            tokStreamBuffer = [],             tokStreamPendingPragmas = [],             tokStreamPrevToken = Nothing,-            tokStreamExtensions = exts,+            tokStreamExtensionSet = mkExtensionSet exts,             tokStreamEOFEmitted = False           } @@ -153,9 +156,10 @@         TokStream           { tokStreamRawTokens = scanAllTokens env lexSt,             tokStreamLayoutState = mkInitialLayoutState True effectiveExts,+            tokStreamBuffer = [],             tokStreamPendingPragmas = [],             tokStreamPrevToken = Nothing,-            tokStreamExtensions = effectiveExts,+            tokStreamExtensionSet = mkExtensionSet effectiveExts,             tokStreamEOFEmitted = False           }   where@@ -170,57 +174,62 @@    in normalizeTokStream         TokStream           { tokStreamRawTokens = scanAllTokens env lexSt,-            tokStreamLayoutState =-              (mkInitialLayoutState False [])-                { layoutBuffer = toks-                },+            tokStreamLayoutState = mkInitialLayoutState False [],+            tokStreamBuffer = toks,             tokStreamPendingPragmas = [],             tokStreamPrevToken = Nothing,-            tokStreamExtensions = [],+            tokStreamExtensionSet = mkExtensionSet [],             tokStreamEOFEmitted = False           } -pragmaFromToken :: LexToken -> Maybe Pragma-pragmaFromToken tok =-  case lexTokenKind tok of-    TkPragma pragma' -> Just pragma'-    _ -> Nothing--isHiddenToken :: LexToken -> Bool-isHiddenToken tok =-  case lexTokenKind tok of-    TkPragma _ -> True-    TkLineComment -> True-    TkBlockComment -> True-    _ -> False- normalizeTokStream :: TokStream -> TokStream normalizeTokStream ts0   | tokStreamEOFEmitted ts0 = ts0-  | otherwise = go ts0+  | otherwise =+      normalizeTokStreamParts+        (tokStreamRawTokens ts0)+        (tokStreamLayoutState ts0)+        (tokStreamBuffer ts0)+        (tokStreamPendingPragmas ts0)+        (tokStreamPrevToken ts0)+        (tokStreamExtensionSet ts0)+        False++-- | 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+  | eofEmitted = finish rawTokens layoutState buffer pendingPragmas+  | otherwise = go rawTokens layoutState buffer pendingPragmas   where-    go ts =-      case layoutBuffer (tokStreamLayoutState ts) of-        tok : rest-          | Just pragma' <- pragmaFromToken tok ->-              go-                ts-                  { tokStreamLayoutState = (tokStreamLayoutState ts) {layoutBuffer = rest},-                    tokStreamPendingPragmas = tokStreamPendingPragmas ts <> [pragma']-                  }-          | isHiddenToken tok ->-              go-                ts-                  { tokStreamLayoutState = (tokStreamLayoutState ts) {layoutBuffer = rest}-                  }-          | otherwise -> ts+    finish rawTokens' layoutState' buffer' pendingPragmas' =+      TokStream+        { tokStreamRawTokens = rawTokens',+          tokStreamLayoutState = layoutState',+          tokStreamBuffer = buffer',+          tokStreamPendingPragmas = pendingPragmas',+          tokStreamPrevToken = prevToken,+          tokStreamExtensionSet = extensionSet,+          tokStreamEOFEmitted = eofEmitted+        }++    go rawTokens' layoutState' buffer' pendingPragmas' =+      case buffer' of+        tok : rest ->+          case lexTokenKind tok of+            TkPragma pragma' ->+              go rawTokens' layoutState' rest (pendingPragmas' <> [pragma'])+            TkLineComment -> go rawTokens' layoutState' rest pendingPragmas'+            TkBlockComment -> go rawTokens' layoutState' rest pendingPragmas'+            _ -> finish rawTokens' layoutState' buffer' pendingPragmas'         [] ->-          case tokStreamRawTokens ts of-            [] -> ts+          case rawTokens' of+            [] -> finish [] layoutState' [] pendingPragmas'             rawTok : rawRest ->-              let (allToks, laySt') = layoutTransition (tokStreamLayoutState ts) rawTok-                  laySt'' = laySt' {layoutBuffer = allToks}-               in go ts {tokStreamRawTokens = rawRest, tokStreamLayoutState = laySt''}+              let (allToks, laySt') = layoutTransition layoutState' rawTok+               in go rawRest laySt' allToks pendingPragmas'+{-# INLINE normalizeTokStreamParts #-}  -- | Step one token from the stream. This is the core primitive used by all -- Stream methods.@@ -239,29 +248,33 @@ stepOne ts   | tokStreamEOFEmitted ts = Nothing   | otherwise =-      let ts0 = normalizeTokStream ts-          laySt = tokStreamLayoutState ts0-       in case layoutBuffer laySt of-            -- Drain buffered tokens first (virtual braces/semicolons)-            tok : rest ->-              let isEOF = lexTokenKind tok == TkEOF-                  pendingPragmas =-                    case lexTokenOrigin tok of-                      InsertedLayout -> tokStreamPendingPragmas ts0-                      FromSource-                        | lexTokenKind tok == TkSpecialSemicolon -> tokStreamPendingPragmas ts0-                        | otherwise -> []-                  ts' =-                    ts0-                      { tokStreamLayoutState = laySt {layoutBuffer = rest},-                        tokStreamPendingPragmas = pendingPragmas,-                        tokStreamPrevToken = Just tok,-                        tokStreamEOFEmitted = isEOF-                      }-               in Just-                    (tok, normalizeTokStream ts')-            [] ->-              Nothing+      case tokStreamBuffer ts of+        -- Drain buffered tokens first (virtual braces/semicolons)+        tok : rest ->+          let kind = lexTokenKind tok+              isEOF = case kind of+                TkEOF -> True+                _ -> False+              pendingPragmas =+                case lexTokenOrigin tok of+                  InsertedLayout -> tokStreamPendingPragmas ts+                  FromSource+                    | TkSpecialSemicolon <- kind -> tokStreamPendingPragmas ts+                    | otherwise -> []+           in Just+                ( tok,+                  normalizeTokStreamParts+                    (tokStreamRawTokens ts)+                    (tokStreamLayoutState ts)+                    rest+                    pendingPragmas+                    (Just tok)+                    (tokStreamExtensionSet ts)+                    isEOF+                )+        [] ->+          Nothing+{-# INLINE stepOne #-}  instance Stream TokStream where   type Token TokStream = LexToken@@ -277,16 +290,15 @@    takeN_ n ts     | n <= 0 = Just ([], ts)-    | otherwise =-        case stepOne ts of-          Nothing -> Nothing-          Just (tok, ts') ->-            let go 1 acc s = Just (reverse (tok : acc), s)-                go k acc s =-                  case stepOne s of-                    Nothing -> Just (reverse (tok : acc), s)-                    Just (t, s') -> go (k - 1) (t : acc) s'-             in go n [] ts'+    | otherwise = go n [] ts+    where+      go 0 acc s = Just (reverse acc, s)+      go k acc s =+        case stepOne s of+          Nothing+            | null acc -> Nothing+            | otherwise -> Just (reverse acc, s)+          Just (tok, s') -> go (k - 1) (tok : acc) s'    takeWhile_ f =     go []

@@ -15,7 +15,7 @@ import CppSupport (preprocessForParserWithoutIncludesIfEnabled) import Data.Char (ord) import Data.Data (Data, dataTypeConstrs, dataTypeOf, gmapQl, isAlgType, showConstr, toConstr)-import Data.Maybe (isNothing)+import Data.Maybe (isNothing, mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T@@ -217,6 +217,7 @@             testCase "shrunk module headers without warnings make progress" test_shrunkModuleHeaderWithoutWarningMakesProgress,             testCase "syntax utility functions cover public edge cases" test_syntaxUtilityFunctions,             testCase "shrunk class default pattern binds make progress" test_shrunkClassDefaultPatternBindMakesProgress,+            testCase "parsed binders carry source spans" test_parsedBindersCarrySourceSpans,             testCase "shrunk arrow command infix lhs modules make progress" test_shrunkArrowCommandInfixLhsModuleMakesProgress,             testCase "shrunk wildcard pattern binds do not cycle" test_shrunkWildcardPatternBindsDoNotCycle,             testCase "shrunk infix expression left operands do not cycle" test_shrunkInfixExprLeftOperandsDoNotCycle,@@ -464,7 +465,7 @@           EParen (EOverloadedLabel "a" "#a")         ]       rendered = map (renderStrict . layoutPretty defaultLayoutOptions . pretty) exprs-      expected = ["( #a,\n   )", "[ #a]", "( #a)"]+      expected = ["( #a, )", "[ #a]", "( #a)"]   assertEqual "pretty-printed forms" expected rendered   mapM_     ( \source ->@@ -523,6 +524,38 @@         assertBool ("expected no parse errors, got: " <> show errs) (null errs)         assertEqual "expected two declarations" 2 (length (moduleDecls modu)) +test_parsedBindersCarrySourceSpans :: Assertion+test_parsedBindersCarrySourceSpans =+  let source =+        T.unlines+          [ "data T a = MkT { field :: a } | a :*: a",+            "f x = x",+            "(+) x y = x",+            "foreign import ccall \"foo\" c_foo :: ()"+          ]+      (errs, modu) = parseModule defaultConfig source+   in do+        assertBool ("expected no parse errors, got: " <> show errs) (null errs)+        case moduleDecls modu of+          [ DeclAnn _ (DeclData dataDecl),+            DeclAnn _ (DeclValue (FunctionBind valueName _)),+            DeclAnn _ (DeclValue (FunctionBind operatorName _)),+            DeclAnn _ (DeclForeign foreignDecl)+            ] -> do+              assertUnqualifiedNameSpan "type constructor" "<input>" 1 6 1 7 5 6 (binderHeadName (dataDeclHead dataDecl))+              case dataDeclConstructors dataDecl of+                [ DataConAnn _ (RecordCon _ _ recordCon [FieldDecl {fieldNames = [fieldName]}]),+                  DataConAnn _ (InfixCon _ _ _ infixCon _)+                  ] -> do+                    assertUnqualifiedNameSpan "record constructor" "<input>" 1 12 1 15 11 14 recordCon+                    assertUnqualifiedNameSpan "record field" "<input>" 1 18 1 23 17 22 fieldName+                    assertUnqualifiedNameSpan "infix constructor" "<input>" 1 35 1 38 34 37 infixCon+                other -> assertFailure ("expected record and infix constructors, got: " <> show other)+              assertUnqualifiedNameSpan "value binder" "<input>" 2 1 2 2 40 41 valueName+              assertUnqualifiedNameSpan "operator binder" "<input>" 3 2 3 3 49 50 operatorName+              assertUnqualifiedNameSpan "foreign binder" "<input>" 4 28 4 33 87 92 (foreignName foreignDecl)+          other -> assertFailure ("expected data, value, operator, and foreign declarations, got: " <> show other)+ test_emptyCaseLayoutAtEof :: Assertion test_emptyCaseLayoutAtEof =   let source = "x = case () of"@@ -605,6 +638,12 @@       assertEqual "end offset" expectedEndOffset sourceSpanEndOffset     NoSourceSpan -> assertFailure "expected SourceSpan, got NoSourceSpan" +assertUnqualifiedNameSpan :: String -> FilePath -> Int -> Int -> Int -> Int -> Int -> Int -> UnqualifiedName -> Assertion+assertUnqualifiedNameSpan label expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset name =+  case mapMaybe (fromAnnotation :: Annotation -> Maybe SourceSpan) (unqualifiedNameAnns name) of+    span' : _ -> assertSourceSpan expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset span'+    [] -> assertFailure ("expected SourceSpan annotation for " <> label <> ", got none")+ assertReadRoundTrip :: (Eq a, Read a, Show a) => String -> [a] -> Assertion assertReadRoundTrip label =   mapM_ $ \value ->@@ -968,7 +1007,8 @@    in case errs of         [] ->           case moduleHead modu of-            Just ModuleHead {moduleHeadExports = Just [ExportAnn _ (ExportVar _ _ name)]} | name == qualifyName Nothing (mkUnqualifiedName NameVarId "f##") -> pure ()+            Just ModuleHead {moduleHeadExports = Just [ExportAnn _ (ExportVar _ _ name)]}+              | stripAnnotations name == qualifyName Nothing (mkUnqualifiedName NameVarId "f##") -> pure ()             other -> assertFailure ("expected export of f##, got: " <> show other)         _ -> assertFailure ("expected parse success for MagicHash export, got: " <> formatParseErrors "<quickcheck>" (Just source) errs) @@ -1197,10 +1237,10 @@    in do         assertBool ("expected no parse errors, got: " <> show errs) (null errs)         assertBool ("expected reparsed pretty output to succeed, got: " <> show reparseErrs) (null reparseErrs)-        case moduleExports modu of-          Just [ExportAnn _ (ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"])] ->-            case moduleExports reparsed of-              Just [ExportAnn _ (ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"])] ->+        case moduleExports (stripAnnotations modu) of+          Just [ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"]] ->+            case moduleExports (stripAnnotations reparsed) of+              Just [ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"]] ->                 pure ()               other ->                 assertFailure ("unexpected reparsed export AST: " <> show other)@@ -1615,8 +1655,8 @@       expected =         """         f [case [] of {  }-          + []-           -> _] = []+         + []+         -> _] = []         """   assertParsedModulePrettyContains source expected @@ -2034,7 +2074,7 @@       case map peelDeclAnn (moduleDecls modu) of         [ DeclClass ClassDecl {classDeclItems = [ClassItemAnn _ (ClassItemDataFamilyDecl dataFamilyDecl)]}           ]-            | binderHeadName (dataFamilyDeclHead dataFamilyDecl) == expectedName,+            | stripAnnotations (binderHeadName (dataFamilyDeclHead dataFamilyDecl)) == expectedName,               map tyVarBinderName (binderHeadParams (dataFamilyDeclHead dataFamilyDecl)) == ["a"],               isNothing (dataFamilyDeclKind dataFamilyDecl) ->                 pure ()@@ -2053,7 +2093,7 @@         [ DeclClass ClassDecl {classDeclItems = [ClassItemAnn _ (ClassItemDataFamilyDecl dataFamilyDecl)]}           ]             | binderHeadForm (dataFamilyDeclHead dataFamilyDecl) == TypeHeadInfix,-              binderHeadName (dataFamilyDeclHead dataFamilyDecl) == expectedName,+              stripAnnotations (binderHeadName (dataFamilyDeclHead dataFamilyDecl)) == expectedName,               map tyVarBinderName (binderHeadParams (dataFamilyDeclHead dataFamilyDecl)) == ["a", "b"],               isNothing (dataFamilyDeclKind dataFamilyDecl) ->                 pure ()

@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: '"\xFF\0bar"#'+tokens:+  - 'TkStringHash "\255\NULbar" "\"\\xFF\\0bar\"#"'+  - 'TkEOF'+status: pass

@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: '"\x3B1"#'+tokens:+  - 'TkError "primitive string literal contains a character outside Latin-1"'+  - 'TkEOF'+status: pass

@@ -0,0 +1,6 @@+extensions: [MagicHash]+input: '"\x3B1"'+tokens:+  - 'TkString "\945"'+  - 'TkEOF'+status: pass

@@ -0,0 +1,15 @@+{- ORACLE_TEST pass -}+module M where++infixl 9 #!++(#!) = undefined++data A = SomeData B++data B = AlgRep Int | Other++phi xedni i = case xedni #! i of+  SomeData a -> case a of+    AlgRep _ -> \_ _ -> 0+    Other -> \x _ -> x

@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout001.hs.+module M where++f = case () of+  () -> ()+  where x = x

@@ -0,0 +1,5 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout002.hs.+module M where++f = if True then do undefined else undefined

@@ -0,0 +1,12 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout003.hs.+module M where++-- The array package used to have things in this sort of pattern, where+-- the "parse error" rule is needed to close the do block's layout++f :: [IO ()]+f = [do+   undefined+   undefined+   | _ <- undefined]

@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout004.hs.+{-# LANGUAGE PatternGuards #-}++module M where++f | Just x <- undefined,+    let y = x,+    undefined x y+  = ()

@@ -0,0 +1,10 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout005.hs.+module M where++-- GHC's Lexer.x had a piece of code like this++f = if True then do+        case () of+            () -> ()+            else ()

@@ -0,0 +1,13 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout006.hs.+module M where++-- GHC's GHC.Parser.PostProcess had a piece of code like this++f :: IO ()+f+ | True = do+ let x = ()+     y = ()+ return ()+ | True = return ()

@@ -0,0 +1,11 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout007.hs.+{-# LANGUAGE TemplateHaskell #-}++module M where++-- The paren here closes the open-splice - it doesn't match an+-- opening paren++f :: IO ()+f = do print $( [| 'a' |] )

@@ -0,0 +1,22 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout008.hs.+{-# LANGUAGE RecursiveDo, DoRec #-}+{-# OPTIONS_GHC -fno-warn-deprecated-flags #-}++module M where++-- do, mdo and rec should all open layouts++f :: IO ()+f = do print 'a'+       print 'b'++g :: IO ()+g = mdo print 'a'+        print 'b'++h :: IO ()+h = do print 'a'+       rec print 'b'+           print 'c'+       print 'd'

@@ -0,0 +1,6 @@+{- ORACLE_TEST pass -}+-- From GHC testsuite/tests/layout/layout009.hs.+module M where++f :: Char+f = let {x = 'a'} in x

@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE GHC2021 #-}++module VariableLeadingInfixDeclarations where++a@_ + _ = []+b :+ _ = []

@@ -0,0 +1,8 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TransformListComp #-}++module BareIfBoundaries where++thenIf = [[] | then if [] then [] else [] by []]++groupByIf = [[] | then group by if [] then [] else [] using []]

@@ -218,7 +218,7 @@     mkGeneratedPerfCase "type-right-leaning-terms" (mkTypeModule (rightLeaningType generatedCaseSize)),     mkGeneratedPerfCase "type-left-leaning-terms" (mkTypeModule (leftLeaningType generatedCaseSize)),     mkGeneratedPerfCase "type-parameters" (mkTypeModule (typeWithParameters generatedCaseSize)),-    mkGeneratedPerfCase "string-escapes" (mkExprModule (escapedStringExpr (generatedCaseSize * 100))),+    mkGeneratedPerfCase "string-escapes" (mkExprModule (escapedStringExpr (generatedCaseSize * 500))),     mkGeneratedPerfCase "nested-application" (mkExprModule (nestedAppExpr generatedCaseSize)),     mkGeneratedPerfCaseWithStatus "xfail-invalid-module" "module Generated where\nvalue = { x = 1, }\n" StatusXFail "regression coverage"   ]@@ -315,7 +315,7 @@  escapedStringExpr :: Int -> Text escapedStringExpr desiredLength =-  T.concat ["\"", takeEscapedText desiredLength escapedStringFragments, "\""]+  T.concat ["\"", takeEscapedText desiredLength (cycle escapedStringFragments), "\""]  escapedStringFragments :: [Text] escapedStringFragments =

@@ -17,21 +17,19 @@   ) where -import Aihc.Parser.Internal.FromTokens-  ( parseDeclFromTokens,+import Aihc.Parser.Internal.Testing+  ( LexToken (..),+    LexTokenKind (..),+    TokenOrigin (..),+    lexModuleTokens,+    lexTokens,+    parseDeclFromTokens,     parseExprFromTokens,     parseImportDeclFromTokens,     parseModuleFromTokens,     parseModuleHeaderFromTokens,     parsePatternFromTokens,     parseTypeFromTokens,-  )-import Aihc.Parser.Lex-  ( LexToken (..),-    LexTokenKind (..),-    TokenOrigin (..),-    lexModuleTokens,-    lexTokens,   ) import Aihc.Parser.Syntax (ExtensionSetting (..), FloatType (..), NumericType (..), SourceSpan (..)) import Aihc.Parser.Syntax qualified as Syntax

@@ -9,9 +9,9 @@   ) where -import Aihc.Parser.Lex (LexToken) import Aihc.Parser.Shorthand (Shorthand (shorthand)) import Aihc.Parser.Syntax+import Aihc.Parser.Token (LexToken) import Data.Char (isAlphaNum, isSpace) import Data.List (isSubsequenceOf) import Test.Properties.Arb.Decl ()