aihc-parser 2.0.0.0 → 3.0.0.0

raw patch · 38 files changed

+573/−292 lines, 38 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +39/−0
• aihc-parser.cabal +1/−1
• common/CppSupport.hs +1/−41
• common/HackageSupport.hs +4/−51
• src/Aihc/Parser.hs +6/−7
• src/Aihc/Parser/Internal/CheckPattern.hs +15/−22
• src/Aihc/Parser/Internal/Common.hs +32/−15
• src/Aihc/Parser/Internal/Expr.hs +7/−13
• src/Aihc/Parser/Internal/FromTokens.hs +1/−2
• src/Aihc/Parser/Internal/Pattern.hs +26/−9
• src/Aihc/Parser/Internal/Type.hs +7/−21
• src/Aihc/Parser/Lex.hs +41/−8
• src/Aihc/Parser/Lex/Types.hs +38/−3
• src/Aihc/Parser/Parens.hs +21/−3
• src/Aihc/Parser/Pretty.hs +20/−7
• src/Aihc/Parser/Shorthand.hs +40/−7
• src/Aihc/Parser/Syntax.hs +27/−11
• src/Aihc/Parser/Types.hs +104/−57
• test/Test/Fixtures/equivalent/pattern/tuple-con-prefix-spacing.yaml +5/−0
• test/Test/Fixtures/golden/expr/view-pattern-arrow.yaml +6/−0
• test/Test/Fixtures/golden/module/builtin-con-promoted.yaml +9/−0
• test/Test/Fixtures/golden/module/builtin-con-unboxed-tuple-type.yaml +7/−0
• test/Test/Fixtures/golden/module/data-con-infix-tuple-constructor-application.yaml +1/−1
• test/Test/Fixtures/golden/module/paren-reserved-operator-expr-rejected.yaml +5/−0
• test/Test/Fixtures/golden/module/promoted-arrow-rejected.yaml +5/−0
• test/Test/Fixtures/golden/module/tuple-con-prefix-patterns.yaml +10/−0
• test/Test/Fixtures/golden/module/tuple-con-typed-pattern-bind.yaml +7/−0
• test/Test/Fixtures/golden/pattern/tuple-con-prefix-triple-paren.yaml +6/−0
• test/Test/Fixtures/golden/pattern/tuple-con-prefix-type-arg.yaml +6/−0
• test/Test/Fixtures/golden/pattern/tuple-con-prefix-unapplied.yaml +6/−0
• test/Test/Fixtures/golden/pattern/tuple-con-prefix.yaml +6/−0
• test/Test/Fixtures/golden/pattern/unboxed-tuple-con-prefix-paren.yaml +6/−0
• test/Test/Fixtures/golden/pattern/unboxed-tuple-con-prefix.yaml +6/−0
• test/Test/Fixtures/oracle/DataKinds/promoted-tuple-constructor.hs +7/−0
• test/Test/Fixtures/oracle/UnboxedTuples/unboxed-tuple-type-constructor.hs +7/−0
• test/Test/Properties/Arb/Expr.hs +4/−1
• test/Test/Properties/Arb/Pattern.hs +17/−1
• test/Test/Properties/Arb/Type.hs +17/−11

@@ -6,6 +6,45 @@  ## [Unreleased] +## [3.0.0.0] - 2026-09-06++### Changed++- **Breaking:** Added the `BuiltinCon` type for the constructors that the+  grammar builds in: `(,)`, `(# , #)`, `(->)`, `[]`, and `(:)`. These+  constructors have no name that a scope can bind, so the AST no longer+  spells them as a `Name`. The type namespace uses `TBuiltinCon BuiltinCon+  TypePromotion` and the pattern namespace uses `PBuiltinCon BuiltinCon+  [Type] [Pattern]`. This replaces `TypeBuiltinCon`, `TBuiltinCon+  TypeBuiltinCon`, and `PTupleCon`.+  - A prefix tuple constructor in a pattern, such as `(,) a b`, parsed as a+    `PCon` whose name was only commas, such as `PCon ","+    [PVar "a", PVar "b"]`. The dedicated pattern parser now also accepts the+    prefix tuple constructor outside parentheses, for example in a `case`+    alternative.+  - An unboxed prefix tuple constructor in a type, such as `(# , #) Int+    Bool`, parsed as `TCon "(#,#)"`. The boxed form already had a dedicated+    constructor.+  - A promoted built-in constructor, such as `'[]`, `'(:)`, or `'(,)`,+    parsed as a `TCon` whose name was the surface syntax, such as `TCon "[]"+    Promoted`. `TBuiltinCon` now carries the promotion flag.+- **Breaking:** Added the `EViewPat` expression constructor for the+  view-pattern arrow. The parser made an `EInfix` with an operator named+  `->`, and `checkPattern` found the view pattern by a comparison against+  that name. No scope binds a term named `->`.+- The parser now rejects `'(->)`, which GHC also rejects. The arrow has no+  promoted form.+- The parser now rejects a reserved operator in a parenthesized expression:+  `(->)`, `(=>)`, `(::)`, `(=)`, `(|)`, `(<-)`, `(..)`, and `(@)`. These+  parsed as an `EVar` with the reserved operator as its name. GHC rejects+  each of them. `(-)` and `(:)` are unchanged.+- Made module parsing about 1.5x faster on the Stackage benchmark corpus and+  reduced allocation by a third. The context-item kind-signature lookahead now+  stops at declaration boundaries instead of scanning to the end of the+  module, the token stream memoizes each step so lookahead and backtracking+  no longer rerun the layout algorithm, and the lexer dispatches on the first+  character of each token.+ ## [2.0.0.0] - 2026-09-03  ### Changed

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

@@ -1,5 +1,3 @@-{-# LANGUAGE OverloadedStrings #-}- module CppSupport   ( preprocessForParser,     preprocessForParserIfEnabled,@@ -20,16 +18,13 @@     preprocess,   ) import Aihc.Hackage.Cpp qualified as HackageCpp+import Aihc.Hackage.Util (normalizeSourceForParser) import Aihc.Parser.Syntax (Extension (CPP), ExtensionSetting (..), ModuleHeaderPragmas (..)) import Aihc.Parser.Token (readModuleHeaderExtensions, readModuleHeaderPragmas) import Data.ByteString (ByteString)-import Data.Char (toLower) import Data.Functor.Identity (Identity (..), runIdentity)-import Data.Maybe (fromMaybe) import Data.Text (Text)-import Data.Text qualified as T import Data.Text.Encoding qualified as TE-import System.FilePath (takeExtension)  preprocessForParser :: (Monad m) => FilePath -> [Text] -> (IncludeRequest -> m (Maybe ByteString)) -> Text -> m Result preprocessForParser inputFile deps resolveInclude source =@@ -87,38 +82,3 @@         EnableExtension CPP -> True         DisableExtension CPP -> False         _ -> enabled--normalizeSourceForParser :: FilePath -> Text -> Text-normalizeSourceForParser inputFile =-  unliterateIfNeeded inputFile . stripLeadingBom--stripLeadingBom :: Text -> Text-stripLeadingBom txt =-  fromMaybe txt (T.stripPrefix "\xfeff" txt)--unliterateIfNeeded :: FilePath -> Text -> Text-unliterateIfNeeded inputFile source-  | map toLower (takeExtension inputFile) /= ".lhs" = source-  | otherwise =-      let ls = T.lines source-       in if any (\line -> T.strip line == "\\begin{code}") ls-            then T.unlines (unlitLatex False ls)-            else T.unlines (map unlitBirdLine ls)-  where-    -- Replace the leading '>' with a space instead of stripping it.-    -- This preserves original column positions, which is critical for-    -- layout-sensitive parsing when tabs are present.  Stripping "> "-    -- shifts columns by 2, but tab stops depend on absolute column-    -- position, so tab-aligned code and space-aligned code would end-    -- up at different columns after the shift.-    unlitBirdLine line =-      case T.stripPrefix ">" line of-        Just _rest -> " " <> _rest-        Nothing -> ""--    unlitLatex _ [] = []-    unlitLatex inCode (line : rest)-      | T.strip line == "\\begin{code}" = "" : unlitLatex True rest-      | T.strip line == "\\end{code}" = "" : unlitLatex False rest-      | inCode = line : unlitLatex inCode rest-      | otherwise = "" : unlitLatex inCode rest

@@ -18,21 +18,20 @@   ) where -import Aihc.Cpp (Diagnostic (..), IncludeKind (..), IncludeRequest (..), Severity (..))+import Aihc.Cpp (Diagnostic (..), IncludeRequest, Severity (..)) import Aihc.Hackage.Cabal qualified as HC+import Aihc.Hackage.Cpp qualified as HCpp import Aihc.Hackage.Download qualified as HD import Aihc.Hackage.Types qualified as HT import Aihc.Hackage.Util qualified as HU import Aihc.Parser.Syntax qualified as Syntax import Data.ByteString qualified as BS-import Data.List (nub) import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Distribution.PackageDescription.Parsec (parseGenericPackageDescription, runParseResult) import Distribution.Types.GenericPackageDescription (GenericPackageDescription)-import System.Directory (doesFileExist)-import System.FilePath (isAbsolute, makeRelative, normalise, splitDirectories, takeDirectory, (</>))+import System.FilePath (takeDirectory)  -- | Download a Hackage package with verbose logging. downloadPackage :: String -> String -> IO FilePath@@ -133,53 +132,7 @@ readTextFileLenient = HU.readTextFileLenient  resolveIncludeBestEffort :: FilePath -> [FilePath] -> FilePath -> IncludeRequest -> IO (Maybe BS.ByteString)-resolveIncludeBestEffort packageRoot includeDirs currentFile req = do-  firstExisting <- firstExistingPath (includeCandidates packageRoot includeDirs currentFile req)-  case firstExisting of-    Nothing -> pure Nothing-    Just includeFile -> Just <$> BS.readFile includeFile--includeCandidates :: FilePath -> [FilePath] -> FilePath -> IncludeRequest -> [FilePath]-includeCandidates packageRoot includeDirs currentFile req =-  map normalise $ nub [dir </> includePath req | dir <- searchDirs]-  where-    includeDir = takeDirectory (includeFrom req)-    sourceRelDir = takeDirectory (makeRelative packageRoot currentFile)-    packageAncestors = ancestorDirs sourceRelDir-    localRoots =-      [ takeDirectory currentFile,-        packageRoot </> sourceRelDir,-        packageRoot </> includeDir-      ]-    systemRoots =-      includeDirs-        <> [ packageRoot </> "include",-             packageRoot </> "includes",-             packageRoot </> "cbits",-             packageRoot-           ]-    searchDirs =-      case includeKind req of-        IncludeLocal -> localRoots <> map (packageRoot </>) packageAncestors <> systemRoots-        IncludeSystem -> systemRoots <> localRoots <> map (packageRoot </>) packageAncestors--ancestorDirs :: FilePath -> [FilePath]-ancestorDirs path =-  case filter (not . null) (splitDirectories path) of-    [] -> []-    parts ->-      [ foldl (</>) "." (take n parts)-      | n <- [length parts, length parts - 1 .. 1]-      ]--firstExistingPath :: [FilePath] -> IO (Maybe FilePath)-firstExistingPath [] = pure Nothing-firstExistingPath (candidate : rest) = do-  let path = if isAbsolute candidate then candidate else normalise candidate-  exists <- doesFileExist path-  if exists-    then pure (Just path)-    else firstExistingPath rest+resolveIncludeBestEffort = HCpp.resolveIncludeBestEffort  diagToText :: Diagnostic -> Text diagToText diag =

@@ -48,7 +48,6 @@ import Data.Word (Word8) import Prettyprinter (Doc, colon, defaultLayoutOptions, layoutPretty, pretty, vcat) import Prettyprinter.Render.String (renderString)-import Text.Megaparsec (runParser)  -- $setup -- >>> :set -XOverloadedStrings@@ -88,7 +87,7 @@ parseExpr :: ParserConfig -> Text -> ParseResult Expr parseExpr cfg input =   let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input-   in case runParser (exprParser <* eofTok) (parserSourceName cfg) ts of+   in case runTokStreamParser (exprParser <* eofTok) (parserSourceName cfg) ts of         Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)         Right expr -> ParseOk expr @@ -102,7 +101,7 @@ parsePattern :: ParserConfig -> Text -> ParseResult Pattern parsePattern cfg input =   let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input-   in case runParser (patternParser <* eofTok) (parserSourceName cfg) ts of+   in case runTokStreamParser (patternParser <* eofTok) (parserSourceName cfg) ts of         Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)         Right pat -> ParseOk pat @@ -116,7 +115,7 @@ parseSignatureType :: ParserConfig -> Text -> ParseResult Type parseSignatureType cfg input =   let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input-   in case runParser (typeSignatureParser <* eofTok) (parserSourceName cfg) ts of+   in case runTokStreamParser (typeSignatureParser <* eofTok) (parserSourceName cfg) ts of         Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)         Right ty -> ParseOk ty @@ -133,7 +132,7 @@ parseType :: ParserConfig -> Text -> ParseResult Type parseType cfg input =   let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input-   in case runParser (typeParser <* eofTok) (parserSourceName cfg) ts of+   in case runTokStreamParser (typeParser <* eofTok) (parserSourceName cfg) ts of         Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)         Right ty -> ParseOk ty @@ -144,7 +143,7 @@ parseDecl :: ParserConfig -> Text -> ParseResult Decl parseDecl cfg input =   let ts = mkTokStream (parserSourceName cfg) (applyImpliedExtensions (parserExtensions cfg)) input-   in case runParser (declParser <* eofTok) (parserSourceName cfg) ts of+   in case runTokStreamParser (declParser <* eofTok) (parserSourceName cfg) ts of         Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)         Right decl -> ParseOk decl @@ -168,7 +167,7 @@         modu <- moduleParser         errs <- drainParseErrors         pure (errs, modu)-   in case runParser parser (parserSourceName cfg) ts of+   in case runTokStreamParser parser (parserSourceName cfg) ts of         Left bundle ->           ( parseErrorBundleToSpannedText bundle,             Module

@@ -57,12 +57,12 @@   EList elems -> PList <$> traverse checkPattern elems   -- Unboxed sum   EUnboxedSum i n e -> PUnboxedSum i n <$> checkPattern e-  -- Infix: only constructor operators (starting with ':') or the view-pattern-  -- arrow @->@ are valid in patterns.+  -- View pattern: @expr -> pat@.+  EViewPat l r -> do+    rPat <- checkPattern r+    Right (PView l rPat)+  -- Infix: only constructor operators (starting with ':') are valid in patterns.   EInfix l op r-    | renderName op == "->" -> do-        rPat <- checkPattern r-        Right (PView l rPat)     | isConLikeOp op -> do         lPat <- checkPattern l         rPat <- checkPattern r@@ -80,6 +80,7 @@     xPat <- checkPattern x     case peelPatternAnn fPat of       PCon name typeArgs args -> Right (PCon name typeArgs (args ++ [xPat]))+      PBuiltinCon con typeArgs args -> Right (PBuiltinCon con typeArgs (args ++ [xPat]))       _ -> Left "invalid pattern: application of non-constructor"   -- Record construction -> record pattern   ERecordCon name fields wc -> do@@ -124,6 +125,7 @@     funPat <- checkPattern fun     case peelPatternAnn funPat of       PCon name typeArgs args -> Right (PCon name (typeArgs ++ [ty]) args)+      PBuiltinCon con typeArgs args -> Right (PBuiltinCon con (typeArgs ++ [ty]) args)       _ -> Left "unexpected type application in pattern"   ETHExpQuote {} -> Left "unexpected Template Haskell expression quote in pattern"   ETHTypedQuote {} -> Left "unexpected Template Haskell typed quote in pattern"@@ -150,23 +152,14 @@ checkTupleElement Nothing = Left "unexpected tuple section in pattern" checkTupleElement (Just e) = checkPattern e +-- | A tuple section with no fields, such as @(,)@ or @(#,,#)@, is the+-- prefix tuple constructor. tupleConstructorPattern :: TupleFlavor -> [Maybe Expr] -> Maybe Pattern tupleConstructorPattern fl elems   | null elems = Nothing-  | all isNothing elems = Just (PCon (tupleConstructorName fl (length elems)) [] [])+  | all isNothing elems = Just (PBuiltinCon (BuiltinTuple fl (length elems)) [] [])   | otherwise = Nothing -tupleConstructorName :: TupleFlavor -> Int -> Name-tupleConstructorName fl arity =-  qualifyName Nothing (mkUnqualifiedName NameConSym symbol)-  where-    symbol = case fl of-      Boxed -> tupleCommas-      Unboxed -> "#" <> tupleCommas <> "#"-    tupleCommas-      | arity == 1 = ""-      | otherwise = mconcat (replicate (arity - 1) ",")- -- | Check that a negated expression is a literal (for PNegLit patterns). checkNegLitPattern :: Expr -> Either Text Pattern checkNegLitPattern inner = case inner of@@ -183,13 +176,13 @@  -- | Try to interpret an expression as a view pattern @expr -> expr@. -- Returns 'Just' the corresponding 'PView' when the expression is an--- 'EInfix' with @->@; 'Nothing' otherwise.  Used by the 'EParen' case of+-- 'EViewPat'; 'Nothing' otherwise.  Used by the 'EParen' case of -- 'checkPattern' to strip the outer parentheses and produce @PView@ -- directly (matching the AST shape that the dedicated pattern parser -- produces). asViewPat :: Expr -> Maybe Pattern-asViewPat (EInfix l op r)-  | renderName op == "->" = case checkPattern r of-      Right rPat -> Just (PView l rPat)-      Left _ -> Nothing+asViewPat (EViewPat l r) =+  case checkPattern r of+    Right rPat -> Just (PView l rPat)+    Left _ -> Nothing asViewPat _ = Nothing

@@ -76,9 +76,9 @@   ) where -import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), closeImplicitLayoutContext)+import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), TokenOrigin (..), closeImplicitLayoutContext) import Aihc.Parser.Syntax-import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, tokStreamExtensionSet)+import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, tokStreamExtensionSet) import Control.Monad (guard) import Data.Char (isUpper) import Data.Functor (($>))@@ -248,12 +248,7 @@     (ignored, pragmaTok : rest)       | Just result <- f pragmaTok -> do           MP.updateParserState $ \st ->-            st-              { MP.stateInput =-                  (MP.stateInput st)-                    { tokStreamPendingPragmas = ignored <> rest-                    }-              }+            st {MP.stateInput = setTokStreamPendingPragmas (ignored <> rest) (MP.stateInput st)}           pure (Just result)       | otherwise -> pure Nothing     _ -> pure Nothing@@ -596,6 +591,10 @@      -- \| Lookahead: check if there's a `::` at the top bracket depth.     -- This avoids ambiguity with the bare constraint parser.+    --+    -- The scan stops at the first token that cannot be part of a context+    -- item. Without these stops, a context-less head such as+    -- @instance C T where ...@ scans through the whole instance body.     hasKindSignatureAtTopLevel :: TokParser Bool     hasKindSignatureAtTopLevel = MP.lookAhead (go 0)       where@@ -606,6 +605,7 @@             TkEOF -> pure False             TkReservedDoubleColon | depth == 0 -> pure True             TkReservedRightArrow | depth == 0 -> pure False+            TkReservedDoubleArrow | depth == 0 -> pure False             TkSpecialComma | depth == 0 -> pure False             TkSpecialLParen -> go (depth + 1)             TkSpecialRParen@@ -619,6 +619,29 @@             TkSpecialRBracket               | depth > 0 -> go (depth - 1)               | otherwise -> pure False+            TkSpecialLBrace+              | lexTokenOrigin tok == InsertedLayout -> pure False+            TkSpecialRBrace+              | lexTokenOrigin tok == InsertedLayout -> pure False+            TkSpecialSemicolon -> pure False+            TkReservedEquals -> pure False+            TkReservedPipe -> pure False+            TkReservedLeftArrow -> pure False+            TkKeywordWhere -> pure False+            TkKeywordDeriving -> pure False+            TkKeywordInstance -> pure False+            TkKeywordClass -> pure False+            TkKeywordData -> pure False+            TkKeywordNewtype -> pure False+            TkKeywordType -> pure False+            TkKeywordImport -> pure False+            TkKeywordModule -> pure False+            TkKeywordLet -> pure False+            TkKeywordIn -> pure False+            TkKeywordDo -> pure False+            TkKeywordOf -> pure False+            TkKeywordThen -> pure False+            TkKeywordElse -> pure False             _ -> go depth     constraintTypeParser = do       first <- constraintTypeAppParser@@ -910,13 +933,7 @@       MP.updateParserState         ( \s ->             let input = MP.stateInput s-             in s-                  { MP.stateInput =-                      input-                        { tokStreamLayoutState = laySt'',-                          tokStreamBuffer = inserted <> tokStreamBuffer input-                        }-                  }+             in s {MP.stateInput = setTokStreamLayout laySt'' (inserted <> tokStreamBuffer input) input}         )       pure True 

@@ -103,10 +103,6 @@   | CmdArrAppLhsAtom   deriving (Eq) --- | The operator name used to represent @->@ in view-pattern expressions.-viewPatArrowName :: Name-viewPatArrowName = qualifyName Nothing (mkUnqualifiedName NameVarSym "->")- -- | Optionally consume a @->@ token and parse the right-hand side as a -- view-pattern expression.  Returns the original expression unchanged when -- no @->@ follows.@@ -114,7 +110,7 @@ maybeViewPattern lhs = do   mArrow <- MP.optional (expectedTok TkReservedRightArrow)   case mArrow of-    Just () -> EInfix lhs viewPatArrowName <$> texprParser+    Just () -> EViewPat lhs <$> texprParser     Nothing -> pure lhs  -- | Like 'exprParser' but also allows the view-pattern arrow @->@ at the@@ -647,6 +643,12 @@   withSpanAnn (EAnn . mkAnnotation) $     EVar <$> parens operatorExprNameParser +-- | Parse the operator inside a parenthesized operator expression such as+-- @(+)@, @(:)@, or @(-)@.+--+-- Reserved operators such as @->@, @=>@, @::@, @|@, @<-@, @=@, @..@, and @\@@+-- are grammar, not names.  They have no term-level meaning, so this parser+-- rejects them, in the same way as GHC. operatorExprNameParser :: TokParser Name operatorExprNameParser =   tokenSatisfy "operator" $ \tok ->@@ -655,16 +657,8 @@       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)

@@ -33,11 +33,10 @@ import Aihc.Parser.Lex (LexToken) import Aihc.Parser.Syntax (Decl, Expr, ImportDecl, Module, ModuleHead, Pattern, Type) import Aihc.Parser.Types-import Text.Megaparsec (runParser)  runParserFromTokens :: TokParser a -> FilePath -> [LexToken] -> ParseResult a runParserFromTokens parser sourceName toks =-  case runParser parser sourceName (mkTokStreamFromTokens toks) of+  case runTokStreamParser parser sourceName (mkTokStreamFromTokens toks) of     Left bundle -> ParseErr (parseErrorBundleToSpannedText bundle)     Right parsed -> ParseOk parsed 

@@ -106,6 +106,10 @@       PAnn         (mkAnnotation NoSourceSpan)         (PCon name typeArgs (args <> [rhs]))+    PBuiltinCon con typeArgs args ->+      PAnn+        (mkAnnotation NoSourceSpan)+        (PBuiltinCon con typeArgs (args <> [rhs]))     _ -> lhs  -- | Parse an atomic pattern (@apat@ in the Haskell Report).@@ -128,20 +132,23 @@  nonAsApatParser :: TokParser Pattern nonAsApatParser = do-  thAny <- thAnyEnabled-  explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces-  requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments-  typeAbstractionsEnabled <- isExtensionEnabled TypeAbstractions   tok <- lookAhead anySingle   case lexTokenKind tok of-    TkTypeApp-      | typeAbstractionsEnabled -> typeBinderPatternParser+    TkTypeApp -> do+      typeAbstractionsEnabled <- isExtensionEnabled TypeAbstractions+      if typeAbstractionsEnabled then typeBinderPatternParser else varOrConPatternParser     TkPrefixBang -> strictPatternParser     TkPrefixTilde -> irrefutablePatternParser-    TkKeywordType-      | explicitNamespacesEnabled || requiredTypeArgumentsEnabled -> explicitTypePatternParser+    TkKeywordType -> do+      explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces+      requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments+      if explicitNamespacesEnabled || requiredTypeArgumentsEnabled+        then explicitTypePatternParser+        else varOrConPatternParser     TkQuasiQuote {} -> quasiQuotePatternParser-    TkTHSplice | thAny -> thSplicePatternParser+    TkTHSplice -> do+      thAny <- thAnyEnabled+      if thAny then thSplicePatternParser else varOrConPatternParser     TkKeywordUnderscore -> wildcardPatternParser     TkInteger {} -> literalPatternParser     TkFloat {} -> literalPatternParser@@ -359,6 +366,7 @@   case fmap lexTokenKind mNextTok of     Just nextKind       | nextKind == closeTok -> unitPatternParser tupleFlavor closeTok+      | nextKind == TkSpecialComma -> tupleConstructorPatternParser tupleFlavor closeTok       | tupleFlavor == Unboxed && nextKind == TkReservedPipe -> parseUnboxedSumPatLeadingBars closeTok     _ -> do       -- For boxed parens, try parsing as a top-level view pattern first.@@ -406,6 +414,14 @@       expectedTok closeTok       pure (PTuple tupleFlavor []) +    -- Parse the prefix tuple constructor @(,)@, @(,,)@, or @(#,#)@.+    -- The opening delimiter is already consumed. The arity is the+    -- number of commas plus one.+    tupleConstructorPatternParser tupleFlavor closeTok = do+      commas <- MP.some (expectedTok TkSpecialComma)+      expectedTok closeTok+      pure (PBuiltinCon (BuiltinTuple tupleFlavor (length commas + 1)) [] [])+     -- Try to parse the paren content as a view pattern: expr -> pat.     -- Uses exprParser which stops before '->', then checks for the arrow.     -- Returns Nothing if the content is not a view pattern.@@ -560,5 +576,6 @@ isPatternAppHead pat =   case peelPatternAnn pat of     PCon {} -> True+    PBuiltinCon {} -> True     PVar name -> isConLikeNameType (unqualifiedNameType name)     _ -> False

@@ -469,8 +469,8 @@   expectedTok TkSpecialRParen   pure $     case (nameQualifier op, nameType op, nameText op) of-      (Nothing, NameVarSym, "->") -> TBuiltinCon TBuiltinArrow-      (Nothing, NameConSym, ":") -> TBuiltinCon TBuiltinCons+      (Nothing, NameVarSym, "->") -> TBuiltinCon BuiltinArrow Unpromoted+      (Nothing, NameConSym, ":") -> TBuiltinCon BuiltinCons Unpromoted       _ -> TCon op Unpromoted  typeQuasiQuoteParser :: TokParser Type@@ -512,7 +512,7 @@   expectedTok TkSpecialLBracket   mClosed <- MP.optional (expectedTok TkSpecialRBracket)   case mClosed of-    Just () -> pure (TBuiltinCon TBuiltinList)+    Just () -> pure (TBuiltinCon BuiltinList Unpromoted)     Nothing -> do       elems <- typeParser `MP.sepBy1` expectedTok TkSpecialComma       expectedTok TkSpecialRBracket@@ -532,11 +532,7 @@       moreCommas <- MP.many (expectedTok TkSpecialComma)       expectedTok closeTok       let arity = 2 + length moreCommas-      case tupleFlavor of-        Boxed -> pure (TBuiltinCon (TBuiltinTuple arity))-        Unboxed -> do-          let tupleConName = "(#" <> T.replicate (arity - 1) "," <> "#)"-          pure (TCon (qualifyName Nothing (mkUnqualifiedName NameConId tupleConName)) Unpromoted)+      pure (TBuiltinCon (BuiltinTuple tupleFlavor arity) Unpromoted)      parenthesizedTypeOrTupleParser tupleFlavor closeTok = do       first <- typeParser@@ -575,20 +571,10 @@       | Just inner <- markTypePromoted sub ->           Just (TAnn ann inner)     TCon name _ -> Just (TCon name Promoted)-    TBuiltinCon con -> Just (promoteBuiltinCon con)+    -- @'(->)@ is not valid syntax: the arrow has no promoted form.+    TBuiltinCon BuiltinArrow _ -> Nothing+    TBuiltinCon con _ -> Just (TBuiltinCon con Promoted)     TList _ elems -> Just (TList Promoted elems)     TTuple tupleFlavor _ elems -> Just (TTuple tupleFlavor Promoted elems)     TTypeApp fn arg -> TTypeApp <$> markTypePromoted fn <*> pure arg     _ -> Nothing--promoteBuiltinCon :: TypeBuiltinCon -> Type-promoteBuiltinCon con =-  TCon-    ( qualifyName Nothing $-        case con of-          TBuiltinTuple arity -> mkUnqualifiedName NameConId ("(" <> T.replicate (max 0 (arity - 1)) "," <> ")")-          TBuiltinArrow -> mkUnqualifiedName NameVarSym "->"-          TBuiltinList -> mkUnqualifiedName NameConId "[]"-          TBuiltinCons -> mkUnqualifiedName NameConSym ":"-    )-    Promoted

@@ -75,6 +75,7 @@ import Data.Maybe (fromMaybe, isJust) import Data.Text (Text, pattern Empty, pattern (:<)) import Data.Text qualified as T+import Data.Text.Unsafe qualified as TU  lexTokens :: Text -> [LexToken] lexTokens = lexTokensWithSourceNameAndExtensions "<input>" []@@ -139,7 +140,10 @@             Empty -> SkipDone st             c :< _               | isHaskellWhitespace c ->-                  go (markHadTrivia (consumeWhile isHaskellWhitespace st))+                  go (skipWhitespace st)+              -- Only '-', '{', and '#' can start trivia; other characters+              -- begin a token.+              | c /= '-' && c /= '{' && c /= '#' -> SkipDone st             _               | Just rest <- T.stripPrefix "--" inp,                 isLineComment rest ->@@ -195,6 +199,34 @@  nextToken :: LexerEnv -> LexerState -> (LexToken, LexerState) nextToken env st =+  -- Dispatch on the first character to skip alternatives that cannot match.+  -- Each branch keeps the relative order of the general chain below, so the+  -- token produced is the same as the one the chain would produce.+  case lexerInput st of+    c :< _+      | isAsciiLower c || isAsciiUpper c || c == '_' ->+          fromMaybe (lexErrorToken st "unexpected character") (lexIdentifier env st)+      | isDigit c ->+          fromMaybe (lexErrorToken st "unexpected character") $+            lexHexFloat env st+              <|> lexFloat env st+              <|> lexIntBase env st+              <|> lexInt env st+      | c == '(' || c == ')' || c == ']' || c == '}' || c == ',' || c == ';' || c == '`' ->+          fromMaybe (lexErrorToken st "unexpected character") (lexSymbol env st)+      | isPlainOperatorStart c ->+          fromMaybe (lexErrorToken st "unexpected character") (lexOperator env st)+    _ -> nextTokenGeneral env st++-- | Symbolic characters that only 'lexOperator' can start a token with.+-- The characters handled by earlier alternatives in 'nextTokenGeneral'+-- (@-@, @!@, @~@, @%@, @@@, @#@, @$@, @?@, @|@, @'@, @"@) are excluded.+isPlainOperatorStart :: Char -> Bool+isPlainOperatorStart c =+  c == '=' || c == '<' || c == '>' || c == '.' || c == '*' || c == '+' || c == '&' || c == '^' || c == '/' || c == '\\' || c == ':'++nextTokenGeneral :: LexerEnv -> LexerState -> (LexToken, LexerState)+nextTokenGeneral env st =   -- Inline chain of alternatives with no intermediate list or closure allocation.   -- (<|>) for Maybe short-circuits on the first Just without allocating.   fromMaybe (lexErrorToken st "unexpected character") $@@ -265,8 +297,8 @@       | isIdentStart c ->           let hasMagicHash = hasExt MagicHash env               (seg, rest0) = consumeIdentTail hasMagicHash rest-              firstChunk = T.take (1 + T.length seg) (lexerInput st)-              (consumed, rest1, isQualified) = gatherQualified hasMagicHash firstChunk rest0+              firstChunk = TU.takeWord8 (utf8CharWidth c + TU.lengthWord8 seg) (lexerInput st)+              (consumed, rest1, isQualified) = gatherQualified hasMagicHash False firstChunk rest0            in case (isQualified || isConIdStart c, rest1) of                 (True, '.' :< dotRest@(opChar :< _))                   | isSymbolicOpChar opChar ->@@ -285,17 +317,18 @@                    in Just (mkToken st st' consumed kind, st')     _ -> Nothing   where-    gatherQualified :: Bool -> Text -> Text -> (Text, Text, Bool)-    gatherQualified hasMH acc chars =+    -- The Bool accumulator records whether a qualifier segment was added.+    gatherQualified :: Bool -> Bool -> Text -> Text -> (Text, Text, Bool)+    gatherQualified hasMH qualified acc chars =       case chars of         '.' :< dotRest@(c' :< more)           | isIdentStart c',             not (T.isSuffixOf "#" acc),             isConIdStart (T.head acc) ->               let (seg, rest) = consumeIdentTail hasMH more-                  segWithHead = T.take (1 + T.length seg) dotRest-               in gatherQualified hasMH (acc <> "." <> segWithHead) rest-        _ -> (acc, chars, T.any (== '.') acc)+                  segWithHead = TU.takeWord8 (utf8CharWidth c' + TU.lengthWord8 seg) dotRest+               in gatherQualified hasMH True (acc <> "." <> segWithHead) rest+        _ -> (acc, chars, qualified)      -- Split a qualified identifier into (module part, name part).     -- E.g. "Data.Maybe." ++ "++" -> ("Data.Maybe", "++")

@@ -38,6 +38,8 @@     advanceChars,     advanceN,     consumeWhile,+    skipWhitespace,+    utf8CharWidth,     tokenStartCol,     virtualSymbolToken,     isSymbolicOpChar,@@ -53,6 +55,7 @@ import Data.Data (Data) import Data.Text (Text) import Data.Text qualified as T+import Data.Text.Unsafe qualified as TU import GHC.Generics (Generic)  data LexTokenKind@@ -375,8 +378,7 @@  advanceChars :: Text -> LexerState -> LexerState advanceChars consumed st =-  let !n = T.length consumed-      go (!line, !col, !byteOff, !atLineStart) ch =+  let go (!line, !col, !byteOff, !atLineStart) ch =         case ch of           '\n' -> (line + 1, 1, byteOff + 1, True)           '\t' ->@@ -389,7 +391,9 @@       (!finalLine, !finalCol, !finalByteOff, !finalAtLineStart) =         T.foldl' go (lexerLine st, lexerCol st, lexerByteOffset st, lexerAtLineStart st) consumed    in st-        { lexerInput = T.drop n (lexerInput st),+        { -- The consumed text is a prefix of the input, so dropping its UTF-8+          -- byte length avoids a second scan of the characters.+          lexerInput = TU.dropWord8 (TU.lengthWord8 consumed) (lexerInput st),           lexerLine = finalLine,           lexerCol = finalCol,           lexerByteOffset = finalByteOff,@@ -403,6 +407,37 @@ consumeWhile f st =   let consumed = T.takeWhile f (lexerInput st)    in advanceChars consumed st++-- | Skip leading Haskell whitespace in one pass and record that trivia was+-- seen. Equivalent to @markHadTrivia (consumeWhile isHaskellWhitespace)@ but+-- without the intermediate slice and the second lexer-state copy.+skipWhitespace :: LexerState -> LexerState+skipWhitespace st =+  let input = lexerInput st+      !len = TU.lengthWord8 input+      go !i !line !col !byteOff !atLineStart+        | i >= len = finish i line col byteOff atLineStart+        | otherwise =+            let TU.Iter ch d = TU.iter input i+             in case ch of+                  '\n' -> go (i + d) (line + 1) 1 (byteOff + 1) True+                  '\t' ->+                    let nextTabStop = 8 - ((col - 1) `mod` 8)+                     in go (i + d) line (col + nextTabStop) (byteOff + 1) atLineStart+                  ' ' -> go (i + d) line (col + 1) (byteOff + 1) atLineStart+                  _+                    | isSpace ch -> go (i + d) line (col + 1) (byteOff + d) atLineStart+                    | otherwise -> finish i line col byteOff atLineStart+      finish i line col byteOff atLineStart =+        st+          { lexerInput = TU.dropWord8 i input,+            lexerLine = line,+            lexerCol = col,+            lexerByteOffset = byteOff,+            lexerAtLineStart = atLineStart,+            lexerHadTrivia = True+          }+   in go 0 (lexerLine st) (lexerCol st) (lexerByteOffset st) (lexerAtLineStart st)  tokenStartCol :: LexToken -> Int tokenStartCol tok =

@@ -654,6 +654,10 @@ typedPatternBindLhsNeedsParens (PAnn _ sub) = typedPatternBindLhsNeedsParens sub typedPatternBindLhsNeedsParens (PCon name typeArgs args) =   not (null typeArgs) || not (null args) || isNothing (nameQualifier name)+-- An unapplied built-in constructor already carries its own delimiters, so+-- @let (,) :: ty = e@ parses without more parentheses.+typedPatternBindLhsNeedsParens (PBuiltinCon _ typeArgs args) =+  not (null typeArgs) || not (null args) typedPatternBindLhsNeedsParens _ = False  addMatchParens :: UnqualifiedName -> Match -> Match@@ -812,8 +816,9 @@ bangTypeNeedsPrefixParens (TParen _) = False bangTypeNeedsPrefixParens TStar {} = True bangTypeNeedsPrefixParens (TCon _ Promoted) = True-bangTypeNeedsPrefixParens (TBuiltinCon TBuiltinCons) = True-bangTypeNeedsPrefixParens (TBuiltinCon _) = False+bangTypeNeedsPrefixParens (TBuiltinCon BuiltinCons Unpromoted) = True+bangTypeNeedsPrefixParens (TBuiltinCon _ Promoted) = True+bangTypeNeedsPrefixParens (TBuiltinCon _ _) = False bangTypeNeedsPrefixParens TImplicitParam {} = True bangTypeNeedsPrefixParens TSplice {} = True -- Compound types: the first rendered character comes from the head/lhs.@@ -866,7 +871,7 @@ infixConOperandNeedsParens (TTuple Unboxed _ _) = False infixConOperandNeedsParens (TUnboxedSum {}) = True infixConOperandNeedsParens (TList _ []) = True-infixConOperandNeedsParens (TBuiltinCon TBuiltinList) = True+infixConOperandNeedsParens (TBuiltinCon BuiltinList _) = True infixConOperandNeedsParens (TInfix {}) = True -- Application head determines what the parser sees first. infixConOperandNeedsParens (TApp f _) = infixConOperandNeedsParens f@@ -1118,6 +1123,9 @@             op             (addExprParensIn (CtxInfixRhs (prec == 1)) rhs)         )+    EViewPat viewExpr rhs ->+      -- The view-pattern arrow only parses directly inside parentheses.+      wrapExpr (prec > 0) (EViewPat (addExprParens viewExpr) (addExprParens rhs))     ENegate inner ->       wrapExpr (prec > 2) (ENegate (addNegateParens inner))     ESectionL lhs op ->@@ -1703,6 +1711,8 @@     PUnboxedSum altIdx arity inner -> PUnboxedSum altIdx arity (addPatternInUnboxedSum altIdx inner)     PList elems -> PList (map addPatternInDelimited elems)     PCon con typeArgs args -> PCon con (map (addTypeIn CtxTypeAtom) typeArgs) (map addPatternAtomParens args)+    PBuiltinCon con typeArgs args ->+      PBuiltinCon con (map (addTypeIn CtxTypeAtom) typeArgs) (map addPatternAtomParens args)     PInfix lhs op rhs -> PInfix (addPatternInfixOperandParens lhs) op (addPatternInfixRhsOperandParens rhs)     PView viewExpr inner ->       wrapPat True (PView (addViewExprParens viewExpr) (addPatternViewInnerParens inner))@@ -1916,6 +1926,7 @@     PSplice {} -> addPatternParens pat     PRecord {} -> addPatternParens pat     PCon _ [] [] -> addPatternParens pat+    PBuiltinCon _ [] [] -> addPatternParens pat     PInfix {} -> wrapPat True (addPatternParens pat)     _ -> wrapPat True (addPatternParens pat) @@ -1930,6 +1941,7 @@     PAnn ann sub -> PAnn ann (addPatternInfixOperandParens sub)     PNegLit _ -> addPatternParens pat     PCon {} -> addPatternParens pat+    PBuiltinCon {} -> addPatternParens pat     PInfix {} -> addPatternParens pat     _ -> addPatternAtomParens pat @@ -1944,6 +1956,7 @@     -- directly as either operand of an infix pattern.     PNegLit {} -> addPatternParens pat     PCon {} -> addPatternParens pat+    PBuiltinCon {} -> addPatternParens pat     PInfix {} -> wrapPat True (addPatternParens pat)     _ -> addPatternAtomParens pat @@ -1956,6 +1969,8 @@ addArrowBndrPatternParens p@(PInfix {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PCon _ (_ : _) _) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PCon _ [] (_ : _)) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PBuiltinCon _ (_ : _) _) = wrapPat True (addPatternParens p)+addArrowBndrPatternParens p@(PBuiltinCon _ [] (_ : _)) = wrapPat True (addPatternParens p) addArrowBndrPatternParens pat = addPatternParens pat  -- | Add parens for a pattern in function-head argument position.@@ -1969,6 +1984,8 @@     PTypeSyntax {} -> wrapPat True (addPatternParens pat)     PCon _ typeArgs args       | not (null typeArgs) || not (null args) -> wrapPat True (addPatternParens pat)+    PBuiltinCon _ typeArgs args+      | not (null typeArgs) || not (null args) -> wrapPat True (addPatternParens pat)     PTypeSig inner@(PVar {}) ty ->       wrapPat True (PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty))     PTypeSig {} -> wrapPat True (addPatternParens pat)@@ -2002,6 +2019,7 @@     PNegLit {} -> wrapPat True (addPatternParens pat)     PTypeSyntax {} -> wrapPat True (addPatternParens pat)     PCon _ (_ : _) [] -> wrapPat True (addPatternParens pat)+    PBuiltinCon _ (_ : _) [] -> wrapPat True (addPatternParens pat)     PAs {} -> addPatternParens pat     PStrict {} -> wrapPat True (addPatternParens pat)     PIrrefutable {} -> wrapPat True (addPatternParens pat)

@@ -454,7 +454,9 @@             | T.any (== '\'') rendered = "' "             | otherwise = "'"        in if promoted == Promoted then promoteTick <> base else base-    TBuiltinCon con -> prettyTypeBuiltinCon con+    TBuiltinCon con promoted ->+      let base = prettyBuiltinCon con+       in if promoted == Promoted then "'" <> base else base     TImplicitParam name inner -> pretty name <+> "::" <+> prettyType inner     TTypeLit lit -> prettyTypeLiteral lit     TStar spelling -> pretty spelling@@ -505,13 +507,19 @@ prettyArrowKind ArrowLinear = "%1" <+> "->" prettyArrowKind (ArrowExplicit ty) = "%" <> prettyType ty <+> "->" -prettyTypeBuiltinCon :: TypeBuiltinCon -> Doc ann-prettyTypeBuiltinCon con =+-- | Print a built-in constructor such as @(,)@, @(# , #)@, @(->)@, @[]@,+-- or @(:)@.+prettyBuiltinCon :: BuiltinCon -> Doc ann+prettyBuiltinCon con =   case con of-    TBuiltinTuple arity -> parens (pretty (T.replicate (max 0 (arity - 1)) ","))-    TBuiltinArrow -> "(->)"-    TBuiltinList -> "[]"-    TBuiltinCons -> "(:)"+    BuiltinTuple tupleFlavor arity ->+      let commas = mconcat (replicate (max 0 (arity - 1)) comma)+       in case tupleFlavor of+            Boxed -> parens commas+            Unboxed -> "(#" <> commas <> "#)"+    BuiltinArrow -> "(->)"+    BuiltinList -> "[]"+    BuiltinCons -> "(:)"  prettyContext :: [Type] -> Doc ann prettyContext constraints =@@ -550,6 +558,8 @@        in hsep ["(#", prettyBarSeparated slots, "#)"]     PList elems -> brackets (hsep (punctuate comma (map prettyPattern elems)))     PCon con typeArgs args -> hsep ([prettyPrefixName con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)+    PBuiltinCon con typeArgs args ->+      hsep ([prettyBuiltinCon con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args)     PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs     PView viewExpr inner ->       prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyPattern inner)@@ -1184,6 +1194,8 @@       "\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts)     EInfix lhs op rhs ->       nest 2 (prettyExpr lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs)+    EViewPat viewExpr rhs ->+      prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyExpr rhs)     ENegate inner -> "-" <+> prettyExprAtStatementStart inner     ESectionL lhs op ->       nest 2 (prettyExpr lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op)@@ -1277,6 +1289,7 @@     Boxed -> parens inner     Unboxed -> hsep ["(#", inner, "#)"] +-- | Print the prefix tuple constructor for the given arity: @(,)@ or @(#,#)@. prettyBinding :: RecordField Expr -> Doc ann prettyBinding field =   if recordFieldPun field

@@ -639,7 +639,10 @@       "TCon"         <+> docName name         <> (if promoted == Promoted then " Promoted" else "")-    TBuiltinCon con -> "TBuiltinCon" <+> pretty (show con)+    TBuiltinCon con promoted ->+      "TBuiltinCon"+        <+> hsep (docBuiltinCon con)+        <> (if promoted == Promoted then " Promoted" else "")     TImplicitParam name inner -> "TImplicitParam" <+> docText name <+> parens (docType inner)     TTypeLit lit -> "TTypeLit" <+> docTypeLiteral lit     TStar {} -> "TStar"@@ -796,6 +799,24 @@                       )                   )               )+    PBuiltinCon con typeArgs args ->+      case typeArgs of+        [] -> "PBuiltinCon" <+> hsep (docBuiltinCon con <> [brackets (hsep (punctuate comma (map docPattern args)))])+        _ ->+          "PBuiltinCon"+            <+> hsep+              ( docBuiltinCon con+                  <> [ braces+                         ( hsep+                             ( punctuate+                                 comma+                                 ( listField docType typeArgs+                                     <> listField docPattern args+                                 )+                             )+                         )+                     ]+              )     PInfix lhs op rhs -> "PInfix" <+> parens (docPattern lhs) <+> docName op <+> parens (docPattern rhs)     PView expr inner -> "PView" <+> parens (docExpr expr) <+> parens (docPattern inner)     PAs name inner -> "PAs" <+> docUnqualifiedName name <+> parens (docPattern inner)@@ -809,13 +830,24 @@  docPatternTupleFields :: TupleFlavor -> [Pattern] -> [Doc ann] docPatternTupleFields tupleFlavor elems =-  flavorFields <> [brackets (hsep (punctuate comma (map docPattern elems)))]-  where-    flavorFields =-      case tupleFlavor of-        Boxed -> []-        _ -> [pretty (show tupleFlavor)]+  docTupleFlavor tupleFlavor <> [brackets (hsep (punctuate comma (map docPattern elems)))] +-- | The shorthand omits the default 'Boxed' flavor.+-- | Render a built-in constructor as its shorthand tag.+docBuiltinCon :: BuiltinCon -> [Doc ann]+docBuiltinCon con =+  case con of+    BuiltinTuple tupleFlavor arity -> ["BuiltinTuple"] <> docTupleFlavor tupleFlavor <> [pretty arity]+    BuiltinArrow -> ["BuiltinArrow"]+    BuiltinList -> ["BuiltinList"]+    BuiltinCons -> ["BuiltinCons"]++docTupleFlavor :: TupleFlavor -> [Doc ann]+docTupleFlavor tupleFlavor =+  case tupleFlavor of+    Boxed -> []+    _ -> [pretty (show tupleFlavor)]+ docLiteral :: Literal -> Doc ann docLiteral lit =   case peelLiteralAnn lit of@@ -858,6 +890,7 @@     ELambdaCase alts -> "ELambdaCase" <+> brackets (hsep (punctuate comma (map docCaseAlt alts)))     ELambdaCases alts -> "ELambdaCases" <+> brackets (hsep (punctuate comma (map docLambdaCaseAlt alts)))     EInfix lhs op rhs -> "EInfix" <+> parens (docExpr lhs) <+> docName op <+> parens (docExpr rhs)+    EViewPat viewExpr rhs -> "EViewPat" <+> parens (docExpr viewExpr) <+> parens (docExpr rhs)     ENegate inner -> "ENegate" <+> parens (docExpr inner)     ESectionL lhs op -> "ESectionL" <+> parens (docExpr lhs) <+> docName op     ESectionR op rhs -> "ESectionR" <+> docName op <+> parens (docExpr rhs)

@@ -15,6 +15,7 @@     ArrAppType (..),     BangType (..),     BinderName,+    BuiltinCon (..),     BinderHead (..),     CallConv (..),     CaseAlt (..),@@ -92,7 +93,6 @@     FloatType (..),     NumericType (..),     TypeLiteral (..),-    TypeBuiltinCon (..),     TypePromotion (..),     ForallVis (..),     ForallTelescope (..),@@ -1247,6 +1247,9 @@     PList [Pattern]   | -- | @Just x@ or @Proxy \@Type@     PCon Name [Type] [Pattern]+  | -- | @(,) x y@ or @(#,#) x y@: a built-in constructor applied to+    -- invisible type arguments and patterns.+    PBuiltinCon BuiltinCon [Type] [Pattern]   | -- | @x :+: y@     PInfix Pattern Name Pattern   | -- | @(view -> pat)@@@ -1319,8 +1322,8 @@     TVar UnqualifiedName   | -- | @Maybe@ or @'Just@     TCon Name TypePromotion-  | -- | @(,)@, @(->)@, @[]@, or @(:)@-    TBuiltinCon TypeBuiltinCon+  | -- | @(,)@, @(# , #)@, @(->)@, @[]@, @(:)@, or a promoted form such as @'[]@+    TBuiltinCon BuiltinCon TypePromotion   | -- | @(?x :: Int) => Int@     TImplicitParam Text Type   | -- | @1@, @"x"@, or @'c'@ at the type level.@@ -1358,17 +1361,26 @@     TWildcard   deriving (Data, Eq, Show, Generic, NFData) --- | Built-in type constructors that have dedicated surface syntax.--- Examples: @(,)@, @(->)@, @[]@, and @(:)@.-data TypeBuiltinCon-  = -- | An @n@-tuple constructor like @(,)@ or @(,,)@.-    TBuiltinTuple Int+-- | A constructor that the grammar builds in.+--+-- These constructors have dedicated surface syntax and no name that a scope+-- can bind, so they get their own representation instead of a 'Name'.+-- Examples: @(,)@, @(# , #)@, @(->)@, @[]@, and @(:)@.+--+-- The same type serves the type namespace ('TBuiltinCon') and the pattern+-- namespace ('PBuiltinCon').  Patterns use 'BuiltinTuple' only; the other+-- constructors have ordinary pattern syntax (@[]@, @(:)@) or no term-level+-- form at all (@(->)@).+data BuiltinCon+  = -- | An @n@-tuple constructor such as @(,)@, @(,,)@, or @(# , #)@.+    -- The 'Int' is the arity, which is the number of commas plus one.+    BuiltinTuple TupleFlavor Int   | -- | @(->)@-    TBuiltinArrow+    BuiltinArrow   | -- | @[]@-    TBuiltinList+    BuiltinList   | -- | @(:)@-    TBuiltinCons+    BuiltinCons   deriving (Data, Eq, Show, Generic, NFData)  typeAnnSpan :: SourceSpan -> Type -> Type@@ -2020,6 +2032,10 @@     ELambdaCases [LambdaCaseAlt]   | -- | @a + b@     EInfix Expr Name Expr+  | -- | @f -> pat@ inside parentheses: the view-pattern arrow.+    -- The arrow is grammar, not an operator that a scope can bind, so it+    -- gets its own constructor.  'checkPattern' turns this into 'PView'.+    EViewPat Expr Expr   | -- | @-x@     ENegate Expr   | -- | @(x +)@

@@ -8,6 +8,9 @@     mkTokStream,     mkTokStreamModule,     mkTokStreamFromTokens,+    setTokStreamLayout,+    setTokStreamPendingPragmas,+    runTokStreamParser,     ParserErrorComponent (..),     FoundToken (..),     mkFoundToken,@@ -93,7 +96,14 @@     tokStreamExtensionSet :: ExtensionSet,     -- | Whether this stream has already emitted TkEOF.     -- After EOF is emitted, 'take1_' returns Nothing.-    tokStreamEOFEmitted :: !Bool+    tokStreamEOFEmitted :: !Bool,+    -- | Memoized result of stepping this stream by one token. Lookahead and+    -- backtracking step the same position many times; sharing the successor+    -- means the layout transition for each raw token runs once.+    --+    -- Never update the other fields with record syntax: build streams with+    -- 'buildTokStream' so this field stays consistent.+    tokStreamNext :: Maybe (LexToken, TokStream)   }  -- -- Manual Eq instance — we skip tokStreamRawTokens since list position is not@@ -136,32 +146,28 @@ mkTokStream :: FilePath -> [Extension] -> Text -> TokStream mkTokStream sourceName exts input =   let (env, lexSt) = mkInitialLexerState sourceName exts input-   in normalizeTokStream-        TokStream-          { tokStreamRawTokens = scanAllTokens env lexSt,-            tokStreamLayoutState = mkInitialLayoutState False exts,-            tokStreamBuffer = [],-            tokStreamPendingPragmas = [],-            tokStreamPrevToken = Nothing,-            tokStreamExtensionSet = mkExtensionSet exts,-            tokStreamEOFEmitted = False-          }+   in normalizeTokStreamParts+        (scanAllTokens env lexSt)+        (mkInitialLayoutState False exts)+        []+        []+        Nothing+        (mkExtensionSet exts)+        False  -- | Create a TokStream for parsing full modules (with module-body layout). -- Also bootstraps LANGUAGE pragma extensions from the module header. mkTokStreamModule :: FilePath -> [Extension] -> Text -> TokStream mkTokStreamModule sourceName baseExts input =   let (env, lexSt) = mkInitialLexerState sourceName effectiveExts input-   in normalizeTokStream-        TokStream-          { tokStreamRawTokens = scanAllTokens env lexSt,-            tokStreamLayoutState = mkInitialLayoutState True effectiveExts,-            tokStreamBuffer = [],-            tokStreamPendingPragmas = [],-            tokStreamPrevToken = Nothing,-            tokStreamExtensionSet = mkExtensionSet effectiveExts,-            tokStreamEOFEmitted = False-          }+   in normalizeTokStreamParts+        (scanAllTokens env lexSt)+        (mkInitialLayoutState True effectiveExts)+        []+        []+        Nothing+        (mkExtensionSet effectiveExts)+        False   where     headerSettings = readModuleHeaderExtensions input     effectiveExts = applyImpliedExtensions (foldr applyExtensionSetting baseExts headerSettings)@@ -171,29 +177,55 @@ mkTokStreamFromTokens :: [LexToken] -> TokStream mkTokStreamFromTokens toks =   let (env, lexSt) = mkInitialLexerState "<tokens>" [] ""-   in normalizeTokStream+   in normalizeTokStreamParts+        (scanAllTokens env lexSt)+        (mkInitialLayoutState False [])+        toks+        []+        Nothing+        (mkExtensionSet [])+        False++-- | Replace the layout state and buffer of a stream. The result is a fresh+-- stream with a consistent memoized successor.+setTokStreamLayout :: LayoutState -> [LexToken] -> TokStream -> TokStream+setTokStreamLayout layoutState buffer ts =+  buildTokStream+    (tokStreamRawTokens ts)+    layoutState+    buffer+    (tokStreamPendingPragmas ts)+    (tokStreamPrevToken ts)+    (tokStreamExtensionSet ts)+    (tokStreamEOFEmitted ts)++-- | Replace the pending hidden pragmas of a stream.+setTokStreamPendingPragmas :: [Pragma] -> TokStream -> TokStream+setTokStreamPendingPragmas pendingPragmas ts =+  buildTokStream+    (tokStreamRawTokens ts)+    (tokStreamLayoutState ts)+    (tokStreamBuffer ts)+    pendingPragmas+    (tokStreamPrevToken ts)+    (tokStreamExtensionSet ts)+    (tokStreamEOFEmitted ts)++-- | Build a stream whose memoized successor is computed from its fields.+buildTokStream :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> TokStream+buildTokStream rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted =+  let ts =         TokStream-          { tokStreamRawTokens = scanAllTokens env lexSt,-            tokStreamLayoutState = mkInitialLayoutState False [],-            tokStreamBuffer = toks,-            tokStreamPendingPragmas = [],-            tokStreamPrevToken = Nothing,-            tokStreamExtensionSet = mkExtensionSet [],-            tokStreamEOFEmitted = False+          { tokStreamRawTokens = rawTokens,+            tokStreamLayoutState = layoutState,+            tokStreamBuffer = buffer,+            tokStreamPendingPragmas = pendingPragmas,+            tokStreamPrevToken = prevToken,+            tokStreamExtensionSet = extensionSet,+            tokStreamEOFEmitted = eofEmitted,+            tokStreamNext = stepOne ts           }--normalizeTokStream :: TokStream -> TokStream-normalizeTokStream ts0-  | tokStreamEOFEmitted ts0 = ts0-  | otherwise =-      normalizeTokStreamParts-        (tokStreamRawTokens ts0)-        (tokStreamLayoutState ts0)-        (tokStreamBuffer ts0)-        (tokStreamPendingPragmas ts0)-        (tokStreamPrevToken ts0)-        (tokStreamExtensionSet ts0)-        False+   in ts  -- | Advance through layout and hidden tokens until the stream is ready for -- 'stepOne'. Keeping the stream fields separate lets a token step normalize@@ -204,15 +236,7 @@   | otherwise = go rawTokens layoutState buffer pendingPragmas   where     finish rawTokens' layoutState' buffer' pendingPragmas' =-      TokStream-        { tokStreamRawTokens = rawTokens',-          tokStreamLayoutState = layoutState',-          tokStreamBuffer = buffer',-          tokStreamPendingPragmas = pendingPragmas',-          tokStreamPrevToken = prevToken,-          tokStreamExtensionSet = extensionSet,-          tokStreamEOFEmitted = eofEmitted-        }+      buildTokStream rawTokens' layoutState' buffer' pendingPragmas' prevToken extensionSet eofEmitted      go rawTokens' layoutState' buffer' pendingPragmas' =       case buffer' of@@ -229,10 +253,9 @@             rawTok : rawRest ->               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.+-- Stream methods; its result is memoized in 'tokStreamNext'. -- -- Tokens are produced in two phases: --@@ -274,8 +297,32 @@                 )         [] ->           Nothing-{-# INLINE stepOne #-} +-- | Run a token parser from the start of a stream.+--+-- The position state that Megaparsec keeps for error rendering is detached+-- from the stream, so the memoized successor chain can be collected as the+-- parser advances.+runTokStreamParser :: MP.Parsec ParserErrorComponent TokStream a -> FilePath -> TokStream -> Either ParseErrorBundle a+runTokStreamParser parser sourceName ts =+  snd (MP.runParser' parser initialState)+  where+    initialState =+      MP.State+        { MP.stateInput = ts,+          MP.stateOffset = 0,+          MP.statePosState =+            MP.PosState+              { MP.pstateInput = detachedStream,+                MP.pstateOffset = 0,+                MP.pstateSourcePos = MP.initialPos sourceName,+                MP.pstateTabWidth = MP.defaultTabWidth,+                MP.pstateLinePrefix = ""+              },+          MP.stateParseErrors = []+        }+    detachedStream = buildTokStream [] (tokStreamLayoutState ts) [] [] Nothing (tokStreamExtensionSet ts) True+ instance Stream TokStream where   type Token TokStream = LexToken   type Tokens TokStream = [LexToken]@@ -286,7 +333,7 @@   chunkLength _ = length   chunkEmpty _ = null -  take1_ = stepOne+  take1_ = tokStreamNext    takeN_ n ts     | n <= 0 = Just ([], ts)@@ -294,7 +341,7 @@     where       go 0 acc s = Just (reverse acc, s)       go k acc s =-        case stepOne s of+        case tokStreamNext s of           Nothing             | null acc -> Nothing             | otherwise -> Just (reverse acc, s)@@ -304,7 +351,7 @@     go []     where       go acc s =-        case stepOne s of+        case tokStreamNext s of           Nothing -> (reverse acc, s)           Just (tok, s')             | f tok -> go (tok : acc) s'

@@ -0,0 +1,5 @@+extensions: []+equivalent:+  - (,) a b+  - ( , ) (a) (b)+status: pass

@@ -0,0 +1,6 @@+extensions: [ViewPatterns]+input: |+  (f -> x)+ast: |-+  EParen (EViewPat (EVar "f") (EVar "x"))+status: pass

@@ -0,0 +1,9 @@+extensions: [DataKinds]+input: |+  type A = '[]+  type B = '(:)+  type C = '(,) Int Int+  type D = '(,,)+ast: |-+  Module {[DeclTypeSyn (TypeSynDecl {Prefix "A", TBuiltinCon BuiltinList Promoted}), DeclTypeSyn (TypeSynDecl {Prefix "B", TBuiltinCon BuiltinCons Promoted}), DeclTypeSyn (TypeSynDecl {Prefix "C", TApp (TApp (TBuiltinCon BuiltinTuple 2 Promoted) (TCon "Int")) (TCon "Int")}), DeclTypeSyn (TypeSynDecl {Prefix "D", TBuiltinCon BuiltinTuple 3 Promoted})]}+status: pass

@@ -0,0 +1,7 @@+extensions: [UnboxedTuples]+input: |+  type A = (# , #) Int Bool+  type B = (# , , #)+ast: |-+  Module {[DeclTypeSyn (TypeSynDecl {Prefix "A", TApp (TApp (TBuiltinCon BuiltinTuple Unboxed 2) (TCon "Int")) (TCon "Bool")}), DeclTypeSyn (TypeSynDecl {Prefix "B", TBuiltinCon BuiltinTuple Unboxed 3})]}+status: pass

@@ -2,5 +2,5 @@ input: |   data A b = (,) Int Int `Infix` b ast: |--  Module {[DeclData (DataDecl {Prefix "A" [TyVarBinder {"b"}], [InfixCon {BangType {TApp (TApp (TBuiltinCon TBuiltinTuple 2) (TCon "Int")) (TCon "Int")}, UnqualifiedName {"Infix"}, BangType {TVar "b"}}]})]}+  Module {[DeclData (DataDecl {Prefix "A" [TyVarBinder {"b"}], [InfixCon {BangType {TApp (TApp (TBuiltinCon BuiltinTuple 2) (TCon "Int")) (TCon "Int")}, UnqualifiedName {"Infix"}, BangType {TVar "b"}}]})]} status: pass

@@ -0,0 +1,5 @@+extensions: []+input: |+  a = (->)+status: fail+reason: GHC rejects a reserved operator as a parenthesized expression

@@ -0,0 +1,5 @@+extensions: [DataKinds]+input: |+  type A = '(->)+status: fail+reason: GHC rejects '(->); the arrow has no promoted form

@@ -0,0 +1,10 @@+extensions: []+input: |+  module TupleConPrefixPatterns where+  graph = array bounds0 [(,) v (mapMaybe key_vertex ks) | (,) v (_, _, ks) <- edges1]+  swap x = case x of (,) a b -> (b, a)+  f ((,) a b) = a+  g (,) = 1+ast: |-+  Module {ModuleHead {"TupleConPrefixPatterns"}, [DeclValue (PatternBind (PVar "graph") (EApp (EApp (EVar "array") (EVar "bounds0")) (EListComp (EApp (EApp (ETuple [Nothing, Nothing]) (EVar "v")) (EParen (EApp (EApp (EVar "mapMaybe") (EVar "key_vertex")) (EVar "ks")))) [CompGen (PBuiltinCon BuiltinTuple 2 [PVar "v", PTuple [PWildcard, PWildcard, PVar "ks"]]) (EVar "edges1")]))), DeclValue (FunctionBind "swap" [Match {MatchHeadPrefix, [PVar "x"], ECase (EVar "x") [CaseAlt (PBuiltinCon BuiltinTuple 2 [PVar "a", PVar "b"]) (ETuple [EVar "b", EVar "a"])]}]), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PParen (PBuiltinCon BuiltinTuple 2 [PVar "a", PVar "b"])], EVar "a"}]), DeclValue (FunctionBind "g" [Match {MatchHeadPrefix, [PBuiltinCon BuiltinTuple 2 []], EInt 1 TInteger}])]}+status: pass

@@ -0,0 +1,7 @@+extensions: [MultiWayIf, PartialTypeSignatures, UnboxedTuples]+input: |+  x = if | let (,) :: _ = [] -> []+  y = if | let (#,#) :: _ = [] -> []+ast: |-+  Module {[DeclValue (PatternBind (PVar "x") (EMultiWayIf [GuardedRhs {[GuardLet [DeclValue (PatternBind (PTypeSig (PBuiltinCon BuiltinTuple 2 []) (TWildcard)) (EList []))]], EList []}])), DeclValue (PatternBind (PVar "y") (EMultiWayIf [GuardedRhs {[GuardLet [DeclValue (PatternBind (PTypeSig (PBuiltinCon BuiltinTuple Unboxed 2 []) (TWildcard)) (EList []))]], EList []}]))]}+status: pass

@@ -0,0 +1,6 @@+extensions: []+input: |+  ((,,) a (Just b) c)+ast: |-+  PParen (PBuiltinCon BuiltinTuple 3 [PVar "a", PParen (PCon "Just" [PVar "b"]), PVar "c"])+status: pass

@@ -0,0 +1,6 @@+extensions: [TypeApplications]+input: |+  ((,) @Int a b)+ast: |-+  PParen (PBuiltinCon BuiltinTuple 2 {[TCon "Int"], [PVar "a", PVar "b"]})+status: pass

@@ -0,0 +1,6 @@+extensions: []+input: |+  (,)+ast: |-+  PBuiltinCon BuiltinTuple 2 []+status: pass

@@ -0,0 +1,6 @@+extensions: []+input: |+  (,) a b+ast: |-+  PBuiltinCon BuiltinTuple 2 [PVar "a", PVar "b"]+status: pass

@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  ((#,,#) a b c)+ast: |-+  PParen (PBuiltinCon BuiltinTuple Unboxed 3 [PVar "a", PVar "b", PVar "c"])+status: pass

@@ -0,0 +1,6 @@+extensions: [UnboxedTuples]+input: |+  (#,#) a b+ast: |-+  PBuiltinCon BuiltinTuple Unboxed 2 [PVar "a", PVar "b"]+status: pass

@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE DataKinds #-}+module PromotedTupleConstructor where++type P = '(,) Int Bool++type T = '(,,)

@@ -0,0 +1,7 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE UnboxedTuples #-}+module UnboxedTupleTypeConstructor where++type P = (# , #) Int Bool++type T = (# , , #)

@@ -181,7 +181,7 @@ genTypeNameQuoteType =   oneof     [ TCon <$> genConName <*> pure Unpromoted,-      pure (TBuiltinCon TBuiltinList),+      pure (TBuiltinCon BuiltinList Unpromoted),       pure (TTuple Boxed Unpromoted []),       pure (TTuple Unboxed Unpromoted [])     ]@@ -503,6 +503,9 @@           <> [EInfix simpleVarExpr op rhs | lhs /= EList [] && not (isSimpleVarExpr lhs)]           <> [EInfix lhs op rhs' | rhs' <- shrinkExpr rhs]           <> [EInfix lhs' op rhs | lhs' <- shrinkExpr lhs]+      EViewPat viewExpr rhs ->+        [EViewPat viewExpr' rhs | viewExpr' <- shrinkExpr viewExpr]+          <> [EViewPat viewExpr rhs' | rhs' <- shrinkExpr rhs]       ENegate inner -> inner : [ENegate inner' | inner' <- shrinkExpr inner]       ESectionL inner op ->         inner

@@ -56,13 +56,15 @@         PTuple Boxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]],         PTuple Unboxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x")], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]],         pure (PList []),-        PCon <$> genConName <*> pure [] <*> pure []+        PCon <$> genConName <*> pure [] <*> pure [],+        genPatternTupleCon <*> pure []       ]     recursiveGenerators =       [ PTuple Boxed <$> genTupleElemsWith,         PTuple Unboxed <$> genUnboxedTupleElemsWith,         PList <$> genListElemsWith,         genPatternConWith,+        genPatternTupleConWith,         genPatternInfixWith,         PParen <$> genPattern,         genRecordPatternWith,@@ -81,6 +83,17 @@ genPatternConWith :: Gen Pattern genPatternConWith = PCon <$> genConName <*> pure [] <*> smallList0 genPattern +-- | Generate a prefix tuple constructor such as @(,)@ or @(#,,#)@ that+-- still needs its argument patterns.+genPatternTupleCon :: Gen ([Pattern] -> Pattern)+genPatternTupleCon = do+  tupleFlavor <- elements [Boxed, Unboxed]+  arity <- chooseInt (2, 4)+  pure (PBuiltinCon (BuiltinTuple tupleFlavor arity) [])++genPatternTupleConWith :: Gen Pattern+genPatternTupleConWith = genPatternTupleCon <*> smallList0 genPattern+ genPatternTypeSigWith :: Gen Pattern genPatternTypeSigWith = PTypeSig <$> genPattern <*> genPatternType @@ -191,6 +204,9 @@         [PCon con' typeArgs args | con' <- shrinkName con]           <> [PCon con typeArgs [] | not (null args)]           <> [PCon con typeArgs args' | args' <- shrinkList shrinkPattern args]+      PBuiltinCon con typeArgs args ->+        [PBuiltinCon con typeArgs [] | not (null args)]+          <> [PBuiltinCon con typeArgs args' | args' <- shrinkList shrinkPattern args]       PInfix lhs op rhs ->         [lhs, rhs]           <> [PInfix lhs' op rhs | lhs' <- shrinkPattern lhs]

@@ -41,7 +41,7 @@         [ TVar <$> genTypeVarName,           (`TCon` Unpromoted) <$> genConName,           (`TCon` Promoted) <$> genConName,-          TBuiltinCon <$> genTypeBuiltinCon,+          genBuiltinConType,           TTypeLit <$> genTypeLiteral,           pure (TStar "*"),           pure TWildcard,@@ -56,7 +56,7 @@         [ TVar <$> genTypeVarName,           (`TCon` Unpromoted) <$> genConName,           (`TCon` Promoted) <$> genConName,-          TBuiltinCon <$> genTypeBuiltinCon,+          genBuiltinConType,           TTypeLit <$> genTypeLiteral,           pure (TStar "*"),           pure TWildcard,@@ -288,15 +288,21 @@         pure (TypeLitChar c (T.pack (show c)))     ] -genTypeBuiltinCon :: Gen TypeBuiltinCon-genTypeBuiltinCon =-  elements-    [ TBuiltinTuple 2,-      TBuiltinTuple 3,-      TBuiltinArrow,-      TBuiltinList,-      TBuiltinCons-    ]+-- | Generate a built-in type constructor with a promotion flag.+-- @'(->)@ has no valid syntax, so the arrow stays unpromoted.+genBuiltinConType :: Gen Type+genBuiltinConType = do+  con <-+    elements+      [ BuiltinTuple Boxed 2,+        BuiltinTuple Boxed 3,+        BuiltinTuple Unboxed 2,+        BuiltinArrow,+        BuiltinList,+        BuiltinCons+      ]+  promotion <- if con == BuiltinArrow then pure Unpromoted else elements [Unpromoted, Promoted]+  pure (TBuiltinCon con promotion)  genSymbolText :: Gen Text genSymbolText = do