aihc-parser 3.0.0.0 → 3.0.1.0
raw patch · 19 files changed
+809/−246 lines, 19 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +44/−0
- aihc-parser.cabal +1/−1
- src/Aihc/Parser/Internal/Cmd.hs +2/−1
- src/Aihc/Parser/Internal/Common.hs +42/−23
- src/Aihc/Parser/Internal/Decl.hs +3/−3
- src/Aihc/Parser/Internal/Expr.hs +59/−69
- src/Aihc/Parser/Internal/Pattern.hs +26/−43
- src/Aihc/Parser/Internal/Type.hs +22/−22
- src/Aihc/Parser/Lex.hs +88/−42
- src/Aihc/Parser/Lex/Types.hs +62/−15
- src/Aihc/Parser/Syntax.hs +14/−4
- src/Aihc/Parser/Types.hs +14/−11
- test/Spec.hs +125/−0
- test/Test/Fixtures/golden/expr/let-binding-head-fallback.yaml +6/−0
- test/Test/Fixtures/golden/expr/proc-parenthesized-bind-fallback.yaml +6/−0
- test/Test/Fixtures/golden/pattern/list-pattern-fallback.yaml +6/−0
- test/Test/Fixtures/golden/pattern/record-pattern-fallback.yaml +6/−0
- test/Test/Fixtures/oracle/TypeApplications/at-operator-in-parens.hs +22/−0
- test/Test/Performance/Suite.hs +261/−12
CHANGELOG.md view
@@ -6,6 +6,50 @@ ## [Unreleased] +## [3.0.1.0] - 2026-09-09++### Performance++- Cut parser wall time by about 10%, allocations by about 4%, and peak heap by+ about 27% on the Stackage corpus benchmark. The lexer decides ASCII+ characters without consulting the Unicode general-category tables, groups+ the keyword table by length, and derives byte offsets from the length of the+ consumed text; the token stream builds its successor strictly instead of+ through a thunk; identifier atoms are built inside a single token match; and+ implied `LANGUAGE` extensions are resolved through a map rather than a+ linear scan.++### Fixed++- Accept `(@)` as a parenthesized operator variable in expressions. A tight+ `@` lexes as a reserved token, and the parenthesized-operator parser rejected+ it, so `(@)`, `(@) 1 2`, and `$(@)` failed to parse even though GHC accepts+ them (rejecting `(@)` only later, in the renamer). The pretty-printer already+ rendered such names as `(@)`, so they did not round-trip. Other reserved+ operators (`->`, `=>`, `::`, `|`, `<-`, `=`, `..`) are still rejected.++- Wrap `DeclPatSynSig`, `DeclDefault`, and `DeclSplice` in `DeclAnn` with a+ source span, like every other top-level declaration. Consumers that locate+ declarations by span (such as attaching `-- |` comments) can now handle+ pattern synonym signatures, `default` declarations, and declaration splices.++- Reuse parsed expressions in nested list, record, and view patterns to avoid+ quadratic backtracking.+- Limit retries for local function bindings to the binding head. Invalid+ nested `let` expressions no longer cause exponential backtracking.+- Parse parenthesized arrow commands before trying expression or pattern+ bindings. Deeply nested commands no longer cause quadratic backtracking.++- Removed exponential backtracking for nested parenthesized block expressions+ in `do` statements, guards, and list comprehensions. Parse expressions first+ and use the pattern parser when pattern-only syntax requires it. This also+ speeds up nested list expressions in these positions.++- Apply `LANGUAGE` settings left to right, the order GHC applies them in, so+ that a later setting overrides an earlier one. A later explicit disable of+ an extension could previously be resurrected by an implication from an+ earlier enable.+ ## [3.0.0.0] - 2026-09-06 ### Changed
aihc-parser.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.8 name: aihc-parser-version: 3.0.0.0+version: 3.0.1.0 build-type: Simple license: Unlicense license-file: LICENSE
src/Aihc/Parser/Internal/Cmd.hs view
@@ -154,7 +154,8 @@ TkKeywordIf -> cmdBodyStmtParser TkKeywordCase -> cmdBodyStmtParser TkReservedBackslash -> cmdBodyStmtParser- TkSpecialLParen -> MP.try cmdBindOrBodyStmtParser <|> MP.try cmdBindStmtParser <|> cmdBodyStmtParser+ -- Try commands first so nested command parentheses are parsed once.+ TkSpecialLParen -> MP.try cmdBodyStmtParser <|> MP.try cmdBindOrBodyStmtParser <|> cmdBindStmtParser _ -> do isPatternBind <- startsWithPatternBind if isPatternBind
src/Aihc/Parser/Internal/Common.hs view
@@ -14,6 +14,7 @@ nameToUnqualified, mkUnqualifiedNameAt, mkNameAt,+ identifierName, identifierNameWithTokenParser, identifierNameParser, identifierUnqualifiedNameParser,@@ -271,19 +272,29 @@ TkQConId modName name | isModuleName (modName <> "." <> name) -> Just (modName <> "." <> name) _ -> Nothing +-- | The 'Name' an identifier token denotes, or 'Nothing' if the token is not+-- an identifier.+--+-- Exposed as a plain function rather than only as a parser so that callers+-- which also need the token itself (for its span) can build their result+-- inside a single token match, instead of pairing the two up and taking the+-- pair apart again in a monadic bind.+identifierName :: LexToken -> Maybe Name+identifierName tok =+ case lexTokenKind tok of+ TkVarId ident -> Just (mkNameAt tok Nothing NameVarId ident)+ TkConId ident -> Just (mkNameAt tok Nothing NameConId ident)+ TkQVarId modName ident -> Just (mkNameAt tok (Just modName) NameVarId ident)+ TkQConId modName ident -> Just (mkNameAt tok (Just modName) NameConId ident)+ _ -> Nothing+ identifierNameWithTokenParser :: TokParser (LexToken, Name) identifierNameWithTokenParser =- tokenSatisfy "identifier" $ \tok ->- case lexTokenKind tok of- 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+ tokenSatisfy "identifier" $ \tok -> (,) tok <$> identifierName tok identifierNameParser :: TokParser Name identifierNameParser =- snd <$> identifierNameWithTokenParser+ tokenSatisfy "identifier" identifierName identifierUnqualifiedNameParser :: TokParser UnqualifiedName identifierUnqualifiedNameParser =@@ -320,7 +331,7 @@ constructorNameParser = tokenSatisfy "constructor identifier" $ \tok -> case lexTokenKind tok of- TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId ident))+ TkConId ident -> Just (mkNameAt tok Nothing NameConId ident) TkQConId modName ident -> Just (mkNameAt tok (Just modName) NameConId ident) _ -> Nothing @@ -356,11 +367,11 @@ operatorNameParser = tokenSatisfy "operator" $ \tok -> case lexTokenKind tok of- TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op))- TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op))+ TkVarSym op -> Just (mkNameAt tok Nothing NameVarSym op)+ TkConSym op -> Just (mkNameAt tok Nothing 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 "@"))+ TkReservedAt -> Just (mkNameAt tok Nothing NameVarSym "@") _ -> Nothing operatorUnqualifiedNameParser :: TokParser UnqualifiedName@@ -684,8 +695,8 @@ constraintOperatorIdentifierParser = tokenSatisfy "constraint operator identifier" $ \tok -> case lexTokenKind tok of- TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name))- TkConId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId name))+ TkVarId name -> Just (mkNameAt tok Nothing NameVarId name)+ TkConId name -> Just (mkNameAt tok Nothing NameConId name) _ -> Nothing unpromotedInfixOperatorParser = tokenSatisfy "type infix operator" $ \tok ->@@ -693,8 +704,8 @@ TkVarSym op | op /= "." && op /= "!" ->- Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op), Unpromoted)- TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op), Unpromoted)+ Just (mkNameAt tok Nothing NameVarSym op, Unpromoted)+ TkConSym op -> Just (mkNameAt tok Nothing 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)@@ -895,10 +906,18 @@ name <- MP.try (binderNameParser <* expectedTok TkReservedAt) PAs name <$> bodyParser +-- | Match a tuple opening delimiter and report the closer that must match it.+--+-- A single token match rather than two alternatives: this parser is tried at+-- very many positions where the next token is neither @(@ nor @(#@, and one+-- token test rejects those positions instead of two. tupleDelimsParser :: TokParser (TupleFlavor, LexTokenKind) tupleDelimsParser =- (expectedTok TkSpecialLParen $> (Boxed, TkSpecialRParen))- <|> (expectedTok TkSpecialUnboxedLParen $> (Unboxed, TkSpecialUnboxedRParen))+ tokenSatisfy "symbol '(' or '(#'" $ \tok ->+ case lexTokenKind tok of+ TkSpecialLParen -> Just (Boxed, TkSpecialRParen)+ TkSpecialUnboxedLParen -> Just (Unboxed, TkSpecialUnboxedRParen)+ _ -> Nothing recordFieldsWithWildcardsParser :: TokParser [a] -> TokParser ([a], Bool) recordFieldsWithWildcardsParser fieldsParser = do@@ -1143,15 +1162,15 @@ symbolicOperatorParser = tokenSatisfy "infix operator" $ \tok -> case lexTokenKind tok of- 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 "%"))+ TkVarSym op -> Just (mkNameAt tok Nothing NameVarSym op)+ TkConSym op -> Just (mkNameAt tok Nothing NameConSym op)+ TkPrefixPercent -> Just (mkNameAt tok Nothing 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 (mkUnqualifiedNameAt tok NameVarSym "-"))+ TkMinusOperator -> Just (mkNameAt tok Nothing NameVarSym "-") -- Reserved operators that can be used as infix operators- TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))+ TkReservedColon -> Just (mkNameAt tok Nothing NameConSym ":") _ -> Nothing backtickIdentifierOperatorParser =
src/Aihc/Parser/Internal/Decl.hs view
@@ -132,7 +132,7 @@ -- constructs (e.g. @$expr@, @$(expr)@ via TH, @[qq|...|]@ via QuasiQuotes), -- so no special dispatch is needed here. exprDeclParser :: TokParser Decl-exprDeclParser = DeclSplice <$> exprParser+exprDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ DeclSplice <$> exprParser -- | Parse a @type@ declaration after the @type@ keyword has been consumed. -- Uses 'typeDeclHeadParser' to handle both prefix and infix type heads,@@ -566,7 +566,7 @@ "typed pattern bindings with '=' require exactly one binder" defaultDeclParser :: TokParser Decl-defaultDeclParser = do+defaultDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do expectedTok TkKeywordDefault DeclDefault <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma) @@ -1570,7 +1570,7 @@ -- | Parse a pattern synonym type signature: @pattern Name1, Name2 :: Type@ patternSynonymSigDeclParser :: TokParser Decl-patternSynonymSigDeclParser = do+patternSynonymSigDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do expectedTok TkKeywordPattern names <- patSynNameParser `MP.sepBy1` expectedTok TkSpecialComma expectedTok TkReservedDoubleColon
src/Aihc/Parser/Internal/Expr.hs view
@@ -31,6 +31,7 @@ -- | Parse an expression, then optionally consume @<-@ and a right-hand side. -- If the arrow is present, the expression is converted to a pattern via -- 'checkPattern' and the result is a bind; otherwise it is an expression.+-- Retry with the pattern parser for syntax that expressions cannot contain. exprOrPatternBindParser :: TokParser Expr -> TokParser Expr ->@@ -38,14 +39,31 @@ (Expr -> a) -> TokParser a exprOrPatternBindParser exprP rhsP bindCtor exprCtor = do- expr <- exprP- mArrow <- MP.optional (expectedTok TkReservedLeftArrow)- case mArrow of- Just () -> do- pat <- liftCheck (checkPattern expr)- bindCtor pat <$> rhsP- Nothing -> pure (exprCtor expr)+ lhs <- MP.try exprOrPattern <|> patternBind+ case lhs of+ Left pat -> bindCtor pat <$> rhsP+ Right expr -> pure (exprCtor expr)+ where+ -- Keep the right-hand side outside 'try'. Only the left-hand side+ -- can require a second parse as a pattern.+ exprOrPattern = do+ expr <- exprP+ -- An expression can stop before a pattern-only argument or suffix.+ MP.notFollowedBy $+ expectedTok TkReservedAt+ <|> expectedTok TkPrefixBang+ <|> expectedTok TkPrefixTilde+ <|> expectedTok TkReservedDoubleColon+ mArrow <- MP.optional (expectedTok TkReservedLeftArrow)+ case mArrow of+ Just () -> Left <$> liftCheck (checkPattern expr)+ Nothing -> pure (Right expr) + patternBind = do+ pat <- patternParser+ expectedTok TkReservedLeftArrow+ pure (Left pat)+ -- | Report core: -- -- > exp -> infixexp ['::' type]@@ -197,41 +215,12 @@ case lexTokenKind tok of TkKeywordLet -> MP.try doLetStmtParser <|> doBindOrExprStmtParser TkKeywordRec -> doRecStmtParser- _ -> MP.try doPatBindStmtParser <|> doBindOrExprStmtParser+ _ -> doBindOrExprStmtParser doBindOrExprStmtParser :: TokParser (DoStmt Expr)-doBindOrExprStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do- mExpr <- MP.optional . MP.try $ exprParser- case mExpr of- Nothing -> do- pat <- patternParser- expectedTok TkReservedLeftArrow- rhs <- region "while parsing '<-' binding" exprParser- pure (DoBind pat rhs)- Just expr -> do- tok <- lookAhead anySingle- case lexTokenKind tok of- TkReservedAt -> do- pat <- patternParser- expectedTok TkReservedLeftArrow- rhs <- region "while parsing '<-' binding" exprParser- pure (DoBind pat rhs)- _ -> do- mArrow <- MP.optional (expectedTok TkReservedLeftArrow)- case mArrow of- Just () -> do- pat <- liftCheck (checkPattern expr)- rhs <- region "while parsing '<-' binding" exprParser- pure (DoBind pat rhs)- Nothing ->- pure (DoExpr expr)--doPatBindStmtParser :: TokParser (DoStmt Expr)-doPatBindStmtParser = withSpanAnn (DoAnn . mkAnnotation) $ do- pat <- patternParser- expectedTok TkReservedLeftArrow- expr <- region "while parsing '<-' binding" exprParser- pure (DoBind pat expr)+doBindOrExprStmtParser =+ withSpanAnn (DoAnn . mkAnnotation) $+ exprOrPatternBindParser exprParser (region "while parsing '<-' binding" exprParser) DoBind DoExpr parseLetDeclsParser :: TokParser [Decl] parseLetDeclsParser = expectedTok TkKeywordLet *> bracedDeclsMaybeEmpty@@ -644,21 +633,28 @@ EVar <$> parens operatorExprNameParser -- | Parse the operator inside a parenthesized operator expression such as--- @(+)@, @(:)@, or @(-)@.+-- @(+)@, @(:)@, 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.+-- 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.+--+-- @\@@ is different: since the whitespace-sensitive @\@@ proposal, GHC's+-- grammar admits @(\@)@ as an ordinary varsym, so @$(\@)@ and @(\@) 1 2@ parse+-- and only fail later in the renamer. A tight @\@@ lexes as 'TkReservedAt'+-- (see 'Aihc.Parser.Lex.lexTypeApplication'), which is why it needs its own+-- case here. operatorExprNameParser :: TokParser Name operatorExprNameParser = tokenSatisfy "operator" $ \tok -> case lexTokenKind tok of- TkVarSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym))- TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym))+ TkVarSym sym -> Just (mkNameAt tok Nothing NameVarSym sym)+ TkConSym sym -> Just (mkNameAt tok Nothing NameConSym sym) TkQVarSym modName sym -> Just (mkNameAt tok (Just modName) NameVarSym sym) TkQConSym modName sym -> Just (mkNameAt tok (Just modName) NameConSym sym)- TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "-"))- TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))+ TkMinusOperator -> Just (mkNameAt tok Nothing NameVarSym "-")+ TkReservedColon -> Just (mkNameAt tok Nothing NameConSym ":")+ TkReservedAt -> Just (mkNameAt tok Nothing NameVarSym "@") _ -> Nothing rhsParser :: TokParser (Rhs Expr)@@ -741,7 +737,7 @@ tok <- lookAhead anySingle case lexTokenKind tok of TkKeywordLet -> MP.try guardLetParser <|> guardBindOrExprParser arrowKind- _ -> MP.try guardPatBindParser <|> guardBindOrExprParser arrowKind+ _ -> guardBindOrExprParser arrowKind -- | Parse a guard expression or pattern bind. guardBindOrExprParser :: RhsArrowKind -> TokParser GuardQualifier@@ -753,12 +749,6 @@ GuardPat GuardExpr -guardPatBindParser :: TokParser GuardQualifier-guardPatBindParser = withSpanAnn (GuardAnn . mkAnnotation) $ do- pat <- patternParser- expectedTok TkReservedLeftArrow- GuardPat pat <$> exprParser- guardLetParser :: TokParser GuardQualifier guardLetParser = withSpanAnn (GuardAnn . mkAnnotation) $ do GuardLet <$> parseLetDeclsStmtParser@@ -1053,7 +1043,7 @@ case lexTokenKind tok of TkKeywordLet -> MP.try compLetStmtParser <|> compGenOrGuardParser TkKeywordThen -> compTransformStmtParser <|> compGenOrGuardParser- _ -> MP.try compPatGenParser <|> compGenOrGuardParser+ _ -> compGenOrGuardParser -- | Parse a TransformListComp qualifier: @then f@, @then f by e@, -- @then group by e using f@, or @then group using f@.@@ -1192,13 +1182,6 @@ withSpanAnn (CompAnn . mkAnnotation) $ exprOrPatternBindParser exprParser (region "while parsing '<-' generator" exprParser) CompGen CompGuard -compPatGenParser :: TokParser CompStmt-compPatGenParser = withSpanAnn (CompAnn . mkAnnotation) $ do- pat <- patternParser- expectedTok TkReservedLeftArrow- expr <- region "while parsing '<-' generator" exprParser- pure (CompGen pat expr)- compLetStmtParser :: TokParser CompStmt compLetStmtParser = withSpanAnn (CompAnn . mkAnnotation) $ do CompLetDecls <$> parseLetDeclsStmtParser@@ -1255,7 +1238,7 @@ <|> implicitParamDeclParser <|> fixityDeclParser <|> (if typeSigPrefix then localTypeSigDeclsParser else MP.empty)- <|> MP.try localFunctionDeclParser+ <|> localFunctionDeclParser <|> localPatternDeclParser localTypeSigDeclsParser :: TokParser Decl@@ -1273,7 +1256,12 @@ localFunctionDeclParser :: TokParser Decl localFunctionDeclParser = withSpanAnn (DeclAnn . mkAnnotation) $ do- (headForm, name, pats) <- functionHeadParserWith patParser apatParser+ -- Only the head can require a retry as a pattern binding. A failed body+ -- must not cause the same nested declarations to be parsed again.+ (headForm, name, pats) <- MP.try $ do+ headParts <- functionHeadParserWith patParser apatParser+ lookAhead (expectedTok TkReservedEquals <|> expectedTok TkReservedPipe)+ pure headParts functionBindDecl headForm name pats <$> equationRhsParser localPatternDeclParser :: TokParser Decl@@ -1303,9 +1291,11 @@ pure $ DeclImplicitParam name rhsExpr whereDecls varExprParser :: TokParser Expr-varExprParser = do- (tok, name) <- identifierNameWithTokenParser- pure (EAnn (mkAnnotation (lexTokenSpan tok)) (EVar name))+varExprParser =+ tokenSatisfy "identifier" $ \tok ->+ case identifierName tok of+ Just name -> Just (EAnn (mkAnnotation (lexTokenSpan tok)) (EVar name))+ Nothing -> Nothing implicitParamExprParser :: TokParser Expr implicitParamExprParser =@@ -1326,7 +1316,7 @@ Just $ EAnn (mkAnnotation (lexTokenSpan tok))- (EVar (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId "_")))+ (EVar (mkNameAt tok Nothing NameVarId "_")) _ -> Nothing -- | Parse Template Haskell quote brackets
src/Aihc/Parser/Internal/Pattern.hs view
@@ -71,9 +71,9 @@ symbolicConOp = tokenSatisfy "constructor operator" $ \tok -> case lexTokenKind tok of- TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op))+ TkConSym op -> Just (mkNameAt tok Nothing NameConSym op) TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op)- TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))+ TkReservedColon -> Just (mkNameAt tok Nothing NameConSym ":") _ -> Nothing backtickConOp = MP.try $@@ -348,16 +348,32 @@ -- fields, where there is no surrounding pair of parens to disambiguate the -- view-pattern arrow from the enclosing syntax. --+-- Reuse a complete expression as a pattern when there is no view arrow.+-- This avoids parsing each nested list or record again.+-- -- This parser is recursive so that deeply nested view patterns such as -- @expr1 -> expr2 -> pat@ are accepted without requiring explicit parentheses -- around each intermediate view pattern. subpatternWithBareViewParser :: TokParser Pattern subpatternWithBareViewParser = do- mView <- MP.optional . MP.try $ do+ mResult <- MP.optional . MP.try $ do expr <- exprParser- expectedTok TkReservedRightArrow- PView expr <$> subpatternWithBareViewParser- maybe patternParser pure mView+ tok <- lookAhead anySingle+ case lexTokenKind tok of+ TkReservedRightArrow -> pure (Left expr)+ TkSpecialComma -> Right <$> liftCheck (checkPattern expr)+ TkSpecialRBracket -> Right <$> liftCheck (checkPattern expr)+ TkSpecialRBrace -> Right <$> liftCheck (checkPattern expr)+ TkSpecialRParen -> Right <$> liftCheck (checkPattern expr)+ TkSpecialUnboxedRParen -> Right <$> liftCheck (checkPattern expr)+ TkReservedPipe -> Right <$> liftCheck (checkPattern expr)+ _ -> fail "incomplete element parse"+ case mResult of+ Just (Left expr) -> do+ expectedTok TkReservedRightArrow+ PView expr <$> subpatternWithBareViewParser+ Just (Right pat) -> pure pat+ Nothing -> patternParser parenOrTuplePatternParser :: TokParser Pattern parenOrTuplePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do@@ -465,7 +481,7 @@ isAs <- startsWithAsPattern if isAs then (False,) <$> patternParser- else (False,) <$> exprThenReclassify+ else (False,) <$> subpatternWithBareViewParser where -- Try to parse an operator as a pattern if it's alone (followed by closing delim), -- otherwise fall back to parsing as an expression.@@ -482,7 +498,7 @@ Just TkSpecialComma -> (True,) <$> operatorPatternParser Just TkReservedPipe -> (True,) <$> operatorPatternParser -- Otherwise, try parsing as expression (for cases like (x + y))- _ -> (False,) <$> exprThenReclassify+ _ -> (False,) <$> subpatternWithBareViewParser -- Parse an operator token as a variable or constructor pattern. operatorPatternParser :: TokParser Pattern@@ -491,9 +507,9 @@ let ann = mkAnnotation (lexTokenSpan tok') case lexTokenKind tok' of TkVarSym op -> pure (PAnn ann (PVar (mkUnqualifiedNameAt tok' NameVarSym op)))- TkConSym op -> pure (PAnn ann (PCon (qualifyName Nothing (mkUnqualifiedNameAt tok' NameConSym op)) [] []))+ TkConSym op -> pure (PAnn ann (PCon (mkNameAt tok' Nothing 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 ":")) [] []))+ TkReservedColon -> pure (PAnn ann (PCon (mkNameAt tok' Nothing NameConSym ":") [] [])) TkReservedAt -> pure (PAnn ann (PVar (mkUnqualifiedNameAt tok' NameVarSym "@"))) _ -> MP.customFailure@@ -502,39 +518,6 @@ unexpectedExpecting = "operator token", unexpectedContext = [] }-- -- Try to parse as expression, then reclassify via checkPattern.- -- When exprParser fails, does not consume the full element (e.g.,- -- '@' from an as-pattern), or checkPattern rejects it (e.g., variable- -- operator in infix position), fall back to patternParser.- --- -- View patterns within tuple elements are also handled here: if '->'- -- follows the parsed expression, it is a view pattern.- exprThenReclassify :: TokParser Pattern- exprThenReclassify = do- mResult <- MP.optional . MP.try $ do- expr <- exprParser- -- Verify the expression consumed the full element: the next token- -- must be a valid delimiter in paren/tuple/sum context. If not- -- (e.g., '@' from an as-pattern), the expression parser stopped- -- too early and we should backtrack to patternParser.- tok <- lookAhead anySingle- case lexTokenKind tok of- TkReservedRightArrow -> pure (Left expr) -- view pattern: defer arrow handling- TkSpecialComma -> Right <$> liftCheck (checkPattern expr)- TkSpecialRParen -> Right <$> liftCheck (checkPattern expr)- TkSpecialUnboxedRParen -> Right <$> liftCheck (checkPattern expr)- TkReservedPipe -> Right <$> liftCheck (checkPattern expr)- _ -> fail "incomplete element parse"- case mResult of- Just (Left expr) -> do- -- View pattern: expr -> pattern- expectedTok TkReservedRightArrow- PView expr <$> subpatternWithBareViewParser- Just (Right pat) ->- pure pat- Nothing ->- patternParser tupleOrParenPatternParser tupleFlavor closeTok = do (isBareOp, first) <- parenPatElementParser
src/Aihc/Parser/Internal/Type.hs view
@@ -22,7 +22,7 @@ import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax import Data.Char (isLower)-import Data.Functor (($>))+import Data.Functor (($>), (<&>)) import Data.Text qualified as T import Text.Megaparsec ((<|>)) import Text.Megaparsec qualified as MP@@ -261,13 +261,13 @@ unpromotedInfixOperatorParser = tokenSatisfy "type infix operator" $ \tok -> case lexTokenKind tok of- TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"), Unpromoted)+ TkReservedColon -> Just (mkNameAt tok Nothing NameConSym ":", Unpromoted) TkVarSym op | op /= "." && op /= "!" && op /= "'" ->- Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op), Unpromoted)- TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op), Unpromoted)+ Just (mkNameAt tok Nothing NameVarSym op, Unpromoted)+ TkConSym op -> Just (mkNameAt tok Nothing 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@@ -281,8 +281,8 @@ typeOperatorIdentifierParser = tokenSatisfy "type operator identifier" $ \tok -> case lexTokenKind tok of- TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name))- TkConId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId name))+ TkVarId name -> Just (mkNameAt tok Nothing NameVarId name)+ TkConId name -> Just (mkNameAt tok Nothing NameConId name) TkQVarId modName name -> Just (mkNameAt tok (Just modName) NameVarId name) TkQConId modName name -> Just (mkNameAt tok (Just modName) NameConId name) _ -> Nothing@@ -294,11 +294,11 @@ -- or ':$$: for a promoted user-defined type operator) tokenSatisfy "promoted type infix operator" $ \tok -> case lexTokenKind tok of- TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"), Promoted)+ TkReservedColon -> Just (mkNameAt tok Nothing NameConSym ":", Promoted) TkVarSym sym | sym /= "." && sym /= "!" ->- Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym), Promoted)- TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym), Promoted)+ Just (mkNameAt tok Nothing NameVarSym sym, Promoted)+ TkConSym sym -> Just (mkNameAt tok Nothing 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@@ -457,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 (mkUnqualifiedNameAt tok NameVarSym sym))- TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym))+ TkVarSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (mkNameAt tok Nothing NameVarSym sym)+ TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (mkNameAt tok Nothing 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 (mkUnqualifiedNameAt tok NameVarSym "->"))- TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"))+ TkReservedRightArrow -> Just (mkNameAt tok Nothing NameVarSym "->")+ TkReservedColon -> Just (mkNameAt tok Nothing NameConSym ":") -- Note: ~ is now lexed as TkVarSym "~" so TkVarSym case handles it _ -> Nothing expectedTok TkSpecialRParen@@ -481,15 +481,15 @@ _ -> Nothing typeIdentifierParser :: TokParser Type-typeIdentifierParser = do- (tok, name) <- identifierNameWithTokenParser- pure $- 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+typeIdentifierParser =+ tokenSatisfy "identifier" $ \tok ->+ identifierName tok <&> \name ->+ 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 = do
src/Aihc/Parser/Lex.hs view
@@ -296,8 +296,9 @@ c :< rest | isIdentStart c -> let hasMagicHash = hasExt MagicHash env- (seg, rest0) = consumeIdentTail hasMagicHash rest- firstChunk = TU.takeWord8 (utf8CharWidth c + TU.lengthWord8 seg) (lexerInput st)+ !firstChunkLen = utf8CharWidth c + identTailBytes hasMagicHash rest+ firstChunk = TU.takeWord8 firstChunkLen (lexerInput st)+ rest0 = TU.dropWord8 firstChunkLen (lexerInput st) (consumed, rest1, isQualified) = gatherQualified hasMagicHash False firstChunk rest0 in case (isQualified || isConIdStart c, rest1) of (True, '.' :< dotRest@(opChar :< _))@@ -356,15 +357,23 @@ | isConIdStart firstChar -> TkConId ident | otherwise -> TkVarId ident +-- | Byte length of the identifier tail at the start of @inp@, including any+-- run of trailing @#@ when MagicHash is enabled.+--+-- 'lexIdentifier' only needs this length, so returning it directly avoids+-- materialising the two 'Text' slices that a @span@ would produce for every+-- identifier in the input.+identTailBytes :: Bool -> Text -> Int+identTailBytes hasMH inp =+ let !tailBytes = TU.lengthWord8 (T.takeWhile isIdentTail inp)+ in if hasMH+ then tailBytes + TU.lengthWord8 (T.takeWhile (== '#') (TU.dropWord8 tailBytes inp))+ else tailBytes+ consumeIdentTail :: Bool -> Text -> (Text, Text) consumeIdentTail hasMH inp =- let (tailPart, rest) = T.span isIdentTail inp- in case rest of- '#' :< _- | hasMH ->- let hashes = T.takeWhile (== '#') rest- in (tailPart <> hashes, T.drop (T.length hashes) rest)- _ -> (tailPart, rest)+ let !n = identTailBytes hasMH inp+ in (TU.takeWord8 n inp, TU.dropWord8 n inp) lexImplicitParam :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState) lexImplicitParam env st@@ -1024,14 +1033,28 @@ in go (n + segLen) (T.drop (T.length tailChars) more) _ -> (T.take n input, chars) +-- | ASCII covers nearly every character in real source, and the Unicode+-- branches below are all guarded by @not (isAscii c)@ anyway, so splitting on+-- 'isAscii' first keeps the general-category tables out of the hot path. isIdentStart :: Char -> Bool-isIdentStart c = isAsciiUpper c || isAsciiLower c || c == '_' || isUniSmall c || isUniLarge c || isUniOtherLetter c+isIdentStart c+ | isAscii c = isAsciiUpper c || isAsciiLower c || c == '_'+ | otherwise = isUniSmall c || isUniLarge c || isUniOtherLetter c isVarIdentifierStartChar :: Char -> Bool isVarIdentifierStartChar c = c == '_' || isAsciiLower c || isUniSmall c +-- | Identifier continuation characters.+--+-- For ASCII, 'isIdentContinue' reduces to 'isDigit': ASCII has no+-- LetterNumber, ModifierLetter, NonSpacingMark or OtherNumber characters. The+-- ASCII branch below is therefore the same predicate as the general one, but+-- without a general-category lookup -- which matters because this runs on+-- every character of every identifier plus the character that ends it. isIdentTail :: Char -> Bool-isIdentTail c = isIdentStart c || isIdentContinue c || c == '\''+isIdentTail c+ | isAscii c = isAsciiUpper c || isAsciiLower c || isDigit c || c == '_' || c == '\''+ | otherwise = isIdentStart c || isIdentContinue c isConIdStart :: Char -> Bool isConIdStart c = isAsciiUpper c || isUniLarge c@@ -1065,39 +1088,62 @@ c :< _ -> isSymbolicOpChar c _ -> False +-- | Classify an identifier as a keyword, if it is one.+--+-- Grouped by byte length so that an ordinary identifier is rejected after a+-- single length comparison instead of being compared against all thirty+-- keywords in turn. Every keyword is ASCII, so its byte length is its+-- character length; a non-ASCII identifier simply matches none of the+-- literals in its group. keywordTokenKind :: ExtensionSet -> Text -> Maybe LexTokenKind keywordTokenKind exts txt =- case txt of- "case" -> Just TkKeywordCase- "class" -> Just TkKeywordClass- "data" -> Just TkKeywordData- "default" -> Just TkKeywordDefault- "deriving" -> Just TkKeywordDeriving- "do" -> Just TkKeywordDo- "else" -> Just TkKeywordElse- "forall" -> Just TkKeywordForall- "foreign" -> Just TkKeywordForeign- "if" -> Just TkKeywordIf- "import" -> Just TkKeywordImport- "in" -> Just TkKeywordIn- "infix" -> Just TkKeywordInfix- "infixl" -> Just TkKeywordInfixl- "infixr" -> Just TkKeywordInfixr- "instance" -> Just TkKeywordInstance- "let" -> Just TkKeywordLet- "module" -> Just TkKeywordModule- "newtype" -> Just TkKeywordNewtype- "of" -> Just TkKeywordOf- "then" -> Just TkKeywordThen- "type" -> Just TkKeywordType- "where" -> Just TkKeywordWhere- "_" -> Just TkKeywordUnderscore- "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+ case TU.lengthWord8 txt of+ 1 -> case txt of+ "_" -> Just TkKeywordUnderscore+ _ -> Nothing+ 2 -> case txt of+ "do" -> Just TkKeywordDo+ "if" -> Just TkKeywordIf+ "in" -> Just TkKeywordIn+ "of" -> Just TkKeywordOf+ "by" | memberExtension TransformListComp exts -> Just TkKeywordBy+ _ -> Nothing+ 3 -> case txt of+ "let" -> Just TkKeywordLet+ "rec" | memberExtension Arrows exts || memberExtension RecursiveDo exts -> Just TkKeywordRec+ "mdo" | memberExtension RecursiveDo exts -> Just TkKeywordMdo+ _ -> Nothing+ 4 -> case txt of+ "case" -> Just TkKeywordCase+ "data" -> Just TkKeywordData+ "else" -> Just TkKeywordElse+ "then" -> Just TkKeywordThen+ "type" -> Just TkKeywordType+ "proc" | memberExtension Arrows exts -> Just TkKeywordProc+ _ -> Nothing+ 5 -> case txt of+ "class" -> Just TkKeywordClass+ "infix" -> Just TkKeywordInfix+ "where" -> Just TkKeywordWhere+ "using" | memberExtension TransformListComp exts -> Just TkKeywordUsing+ _ -> Nothing+ 6 -> case txt of+ "forall" -> Just TkKeywordForall+ "import" -> Just TkKeywordImport+ "infixl" -> Just TkKeywordInfixl+ "infixr" -> Just TkKeywordInfixr+ "module" -> Just TkKeywordModule+ _ -> Nothing+ 7 -> case txt of+ "default" -> Just TkKeywordDefault+ "foreign" -> Just TkKeywordForeign+ "newtype" -> Just TkKeywordNewtype+ "pattern" | memberExtension PatternSynonyms exts -> Just TkKeywordPattern+ _ -> Nothing+ 8 -> case txt of+ "deriving" -> Just TkKeywordDeriving+ "instance" -> Just TkKeywordInstance+ _ -> Nothing _ -> Nothing reservedOpTokenKind :: Text -> Maybe LexTokenKind
src/Aihc/Parser/Lex/Types.hs view
@@ -376,27 +376,43 @@ sourceSpanEndOffset = lexerByteOffset end } +-- | Consume a prefix of the input, updating the source position.+--+-- Every character advances the byte offset by its own UTF-8 width, so the new+-- offset is just the old one plus the byte length of @consumed@; only the+-- line/column/line-start fields need a scan. That scan walks byte indices+-- with 'TU.iter' so the UTF-8 width of each character comes from the iterator+-- instead of being recomputed from the character. advanceChars :: Text -> LexerState -> LexerState advanceChars consumed st =- let go (!line, !col, !byteOff, !atLineStart) ch =- case ch of- '\n' -> (line + 1, 1, byteOff + 1, True)- '\t' ->- let nextTabStop = 8 - ((col - 1) `mod` 8)- in (line, col + nextTabStop, byteOff + 1, atLineStart)- ' ' -> (line, col + 1, byteOff + 1, atLineStart)- _- | isSpace ch -> (line, col + 1, byteOff + utf8CharWidth ch, atLineStart)- | otherwise -> (line, col + 1, byteOff + utf8CharWidth ch, False)- (!finalLine, !finalCol, !finalByteOff, !finalAtLineStart) =- T.foldl' go (lexerLine st, lexerCol st, lexerByteOffset st, lexerAtLineStart st) consumed+ let !nbytes = TU.lengthWord8 consumed+ go !i !line !col !atLineStart+ | i >= nbytes = (line, col, atLineStart)+ | otherwise =+ let TU.Iter ch d = TU.iter consumed i+ in case ch of+ '\n' -> go (i + d) (line + 1) 1 True+ '\t' ->+ let nextTabStop = 8 - ((col - 1) `mod` 8)+ in go (i + d) line (col + nextTabStop) atLineStart+ _+ -- Printable ASCII is the overwhelmingly common case and+ -- is never a space character, so it is settled before the+ -- 'isSpace' test. Space itself (and any other space+ -- character) falls through to the guard below, which+ -- leaves 'atLineStart' alone exactly as before.+ | ch > ' ' && isAscii ch -> go (i + d) line (col + 1) False+ | isSpace ch -> go (i + d) line (col + 1) atLineStart+ | otherwise -> go (i + d) line (col + 1) False+ (!finalLine, !finalCol, !finalAtLineStart) =+ go 0 (lexerLine st) (lexerCol st) (lexerAtLineStart st) in 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),+ lexerInput = TU.dropWord8 nbytes (lexerInput st), lexerLine = finalLine, lexerCol = finalCol,- lexerByteOffset = finalByteOff,+ lexerByteOffset = lexerByteOffset st + nbytes, lexerAtLineStart = finalAtLineStart } @@ -468,8 +484,39 @@ | code <= 0xFFFF -> 3 | otherwise -> 4 +-- | Characters that may appear in a symbolic operator.+--+-- The ASCII branch lists exactly @:!#$%&*+./\<=>?\@\\^|-~@; every ASCII+-- character that 'isUnicodeSymbol' would accept (@+ \< = > | ~ $@) is already+-- in that list, so the split loses nothing. It is written as a @case@ rather+-- than @elem@ over a string because this predicate runs on nearly every lexed+-- character and @elem@ would walk a 21-element list each time. isSymbolicOpChar :: Char -> Bool-isSymbolicOpChar c = c `elem` (":!#$%&*+./<=>?@\\^|-~" :: String) || isUnicodeSymbol c+isSymbolicOpChar c+ | isAscii c =+ case c of+ ':' -> True+ '!' -> True+ '#' -> True+ '$' -> True+ '%' -> True+ '&' -> True+ '*' -> True+ '+' -> True+ '.' -> True+ '/' -> True+ '<' -> True+ '=' -> True+ '>' -> True+ '?' -> True+ '@' -> True+ '\\' -> True+ '^' -> True+ '|' -> True+ '-' -> True+ '~' -> True+ _ -> False+ | otherwise = isUnicodeSymbol c isUnicodeSymbol :: Char -> Bool isUnicodeSymbol c =
src/Aihc/Parser/Syntax.hs view
@@ -650,16 +650,26 @@ EnableExtension ext -> ext : filter (/= ext) extensions DisableExtension ext -> filter (/= ext) extensions +-- | 'impliedExtensions' as a map. The fixpoint below looks up every enabled+-- extension on every iteration, which is too many linear scans of the table.+impliedExtensionMap :: Map.Map Extension [ExtensionSetting]+impliedExtensionMap = Map.fromList impliedExtensions+ applyImpliedExtensions :: [Extension] -> [Extension] applyImpliedExtensions extensions =- let settings = concat $ mapMaybe (`lookup` impliedExtensions) extensions+ let settings = concat $ mapMaybe (`Map.lookup` impliedExtensionMap) extensions newExtensions = foldr applyExtensionSetting extensions settings in if sort newExtensions == sort extensions then extensions else applyImpliedExtensions newExtensions +-- | Apply 'LANGUAGE' settings left to right, the order GHC applies them in,+-- so that a later setting overrides an earlier one. Implications are applied+-- immediately after each enable, so a later explicit disable can override an+-- implication instead of having it resurrected by a final implication pass. effectiveExtensions :: LanguageEdition -> [ExtensionSetting] -> [Extension]-effectiveExtensions edition extensionSettings =- applyImpliedExtensions $- foldr applyExtensionSetting (languageEditionExtensions edition) extensionSettings+effectiveExtensions edition = List.foldl' applyOne (languageEditionExtensions edition)+ where+ applyOne extensions setting@(EnableExtension _) = applyImpliedExtensions (applyExtensionSetting setting extensions)+ applyOne extensions setting@(DisableExtension _) = applyExtensionSetting setting extensions -- | Source location metadata for parsed syntax. -- Example: the span covering @map@ in @map f xs@.
src/Aihc/Parser/Types.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-}@@ -284,17 +285,19 @@ FromSource | TkSpecialSemicolon <- kind -> tokStreamPendingPragmas ts | otherwise -> []- in Just- ( tok,- normalizeTokStreamParts- (tokStreamRawTokens ts)- (tokStreamLayoutState ts)- rest- pendingPragmas- (Just tok)- (tokStreamExtensionSet ts)- isEOF- )+ -- The successor is demanded as soon as the parser asks for the+ -- token after this one, which is what almost always happens, so+ -- building it here avoids a thunk per token.+ !next =+ normalizeTokStreamParts+ (tokStreamRawTokens ts)+ (tokStreamLayoutState ts)+ rest+ pendingPragmas+ (Just tok)+ (tokStreamExtensionSet ts)+ isEOF+ in Just (tok, next) [] -> Nothing
test/Spec.hs view
@@ -222,6 +222,7 @@ testCase "runs the parser when its result is forced" test_lazyForcesParserWhenResultIsForced, testCase "preserves errors from the lazy parser" test_lazyPreservesErrors ],+ testCase "preserves patterns in expression and binding positions" test_bindingPatternFallback, testCase "emits lexer error token for unterminated strings" test_unterminatedStringProducesErrorToken, testCase "emits lexer error token for unterminated block comments" test_unterminatedBlockCommentProducesErrorToken, testCase "applies hash line directives to subsequent tokens" test_hashLineDirectiveUpdatesSpan,@@ -262,6 +263,7 @@ 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 "every top-level declaration carries a source span" test_everyTopLevelDeclarationCarriesSourceSpan, 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,@@ -303,6 +305,10 @@ testCase "parenthesizes if RHS before following infix operators" test_ifInfixRhsBeforeFollowingInfixParens, testCase "parenthesizes infix RHS operands inside left sections" test_infixRhsInsideLeftSectionParens, testCase "pretty-prints reserved at right sections" test_prettyReservedAtRightSection,+ testCase "pretty-prints reserved at operator variables" test_prettyReservedAtOperatorVariable,+ testCase "parses applications of reserved at operator variables" test_reservedAtOperatorVariableApplication,+ testCase "parses reserved at operator variables in pattern splices" test_reservedAtOperatorVariableInPatternSplice,+ testCase "rejects reserved operators as parenthesized operator expressions" test_parenOperatorExprRejectsReservedOperators, testCase "pretty-prints type applications after layout-ending functions" test_prettyTypeAppAfterLayoutEndingFunction, testCase "pretty-prints type signatures after layout-ending functions" test_prettyTypeSigAfterLayoutEndingFunction, testCase "pretty-prints operators after layout-rendered do blocks" test_prettyOperatorAfterLayoutDoBlock,@@ -600,6 +606,64 @@ assertUnqualifiedNameSpan "foreign binder" "<input>" 4 28 4 33 87 92 (foreignName foreignDecl) other -> assertFailure ("expected data, value, operator, and foreign declarations, got: " <> show other) +-- | Every top-level declaration form must be wrapped in 'DeclAnn' with a real+-- source span, so that consumers (e.g. haddock comment attachment) can locate+-- declarations by position. Regression test for 'DeclPatSynSig', 'DeclDefault'+-- and 'DeclSplice', which used to be returned unwrapped.+test_everyTopLevelDeclarationCarriesSourceSpan :: Assertion+test_everyTopLevelDeclarationCarriesSourceSpan =+ let source =+ T.unlines+ [ "{-# LANGUAGE PatternSynonyms, RoleAnnotations, StandaloneDeriving #-}",+ "{-# LANGUAGE StandaloneKindSignatures, TemplateHaskell, TypeData #-}",+ "{-# LANGUAGE TypeFamilies #-}",+ "module M where",+ "import Data.Kind (Type)",+ "type T :: Type -> Type",+ "data T a = MkT a",+ "type role T nominal",+ "type data N = Z",+ "newtype I a = I a",+ "type P a = (a, a)",+ "class C a where { m :: a -> a }",+ "instance C Int where { m = id }",+ "deriving instance Show (T Int)",+ "default (Integer, Double)",+ "infixr 5 `seq`",+ "f, g :: Int -> Int",+ "f = id",+ "g = id",+ "foreign import ccall \"puts\" c_puts :: Int -> IO Int",+ "type family F a",+ "data family DF a",+ "type instance F Int = Bool",+ "data instance DF Int = DFInt",+ "{-# INLINE f #-}",+ "pattern Q :: Int -> T Int",+ "pattern Q x = MkT x",+ "$(pure [])"+ ]+ -- 'DeclAnn' is the wrapper itself and 'DeclImplicitParam' only occurs in+ -- local binding groups, so neither can appear at the top level.+ nonTopLevelConstrs = Set.fromList ["DeclAnn", "DeclImplicitParam"]+ allConstrs =+ Set.fromList (map showConstr (dataTypeConstrs (dataTypeOf (undefined :: Decl))))+ `Set.difference` nonTopLevelConstrs+ (errs, modu) = parseModule defaultConfig source+ in do+ assertBool ("expected no parse errors, got: " <> show errs) (null errs)+ let lacksSpan decl = case decl of+ DeclAnn ann _ -> isNothing (fromAnnotation ann :: Maybe SourceSpan)+ _ -> True+ unannotated =+ [showConstr (toConstr decl) | decl <- moduleDecls modu, lacksSpan decl]+ assertEqual "declarations without a DeclAnn source span" [] unannotated+ let covered = Set.fromList (map (showConstr . toConstr . peelDeclAnn) (moduleDecls modu))+ assertEqual+ "declaration forms not exercised by this fixture"+ Set.empty+ (allConstrs `Set.difference` covered)+ test_emptyCaseLayoutAtEof :: Assertion test_emptyCaseLayoutAtEof = let source = "x = case () of"@@ -1483,6 +1547,43 @@ assertEqual "pretty-printed expression" "(@ ())" rendered assertExprRenderingRoundTrip defaultConfig expr rendered +test_prettyReservedAtOperatorVariable :: Assertion+test_prettyReservedAtOperatorVariable = do+ let expr = EVar (qualifyName Nothing (mkUnqualifiedName NameVarSym "@"))+ rendered = renderPretty expr+ assertEqual "pretty-printed expression" "(@)" rendered+ assertExprRenderingRoundTrip defaultConfig expr rendered++test_reservedAtOperatorVariableApplication :: Assertion+test_reservedAtOperatorVariableApplication =+ assertParsedStrippedDeclShapeRoundTrip defaultConfig "f = (@) 1 2"++test_reservedAtOperatorVariableInPatternSplice :: Assertion+test_reservedAtOperatorVariableInPatternSplice = do+ let config = defaultConfig {parserExtensions = requiredExtensions}+ source =+ """+ _ = [[]+ | let $(@) `a` _ = []]+ """+ assertParsedStrippedDeclShapeRoundTrip config source++test_parenOperatorExprRejectsReservedOperators :: Assertion+test_parenOperatorExprRejectsReservedOperators =+ mapM_ assertRejected ["(->)", "(=>)", "(::)", "(|)", "(<-)", "(=)", "(..)"]+ where+ config = defaultConfig {parserExtensions = requiredExtensions}+ assertRejected source =+ case parseExpr config source of+ ParseErr {} -> pure ()+ ParseOk expr ->+ assertFailure+ ( "expected parse failure for "+ <> T.unpack source+ <> ", got: "+ <> show (shorthand (stripAnnotations expr))+ )+ test_prettyTypeAppAfterLayoutEndingFunction :: Assertion test_prettyTypeAppAfterLayoutEndingFunction = do let config = defaultConfig {parserExtensions = requiredExtensions}@@ -2273,3 +2374,27 @@ ] ) (null failures)++-- Each suffix must trigger the fallback without an earlier pattern prefix.+test_bindingPatternFallback :: Assertion+test_bindingPatternFallback =+ mapM_ check ["K !x", "K ~x", "K y@(Just z)", "x@(Just y)", "(id -> x)", "x :: Int", "(x, y)", "(-1)", "(:)", "(,)", "[x, y]"]+ where+ config = defaultConfig {parserExtensions = [BangPatterns, ViewPatterns, ScopedTypeVariables]}+ check source = case parsePattern config source of+ ParseErr errs -> assertFailure (formatParseErrors "<test>" (Just source) errs)+ ParseOk expected ->+ mapM_+ (checkContext (stripAnnotations expected))+ [ "do { " <> source <> " <- xs; pure () }",+ "[() | " <> source <> " <- xs]",+ "case () of { _ | " <> source <> " <- xs -> () }"+ ]+ checkContext expected source = case parseExpr config source of+ ParseErr errs -> assertFailure (formatParseErrors "<test>" (Just source) errs)+ ParseOk expr -> case stripAnnotations expr of+ EDo [DoBind pat _, DoExpr _] _ -> assertEqual (T.unpack source) expected pat+ EListComp _ [CompGen pat _] -> assertEqual (T.unpack source) expected pat+ ECase _ [CaseAlt _ _ (GuardedRhss _ [GuardedRhs _ [GuardPat pat _] _] Nothing)] ->+ assertEqual (T.unpack source) expected pat+ actual -> assertFailure ("unexpected binding structure: " <> show actual)
+ test/Test/Fixtures/golden/expr/let-binding-head-fallback.yaml view
@@ -0,0 +1,6 @@+extensions: []+input: |+ let { x@(Just y) = value; f z = z; (a, b) = pair } in y+ast: |-+ ELetDecls [DeclValue (PatternBind (PAs UnqualifiedName {"x"} (PParen (PCon "Just" [PVar "y"]))) (EVar "value")), DeclValue (FunctionBind "f" [Match {MatchHeadPrefix, [PVar "z"], EVar "z"}]), DeclValue (PatternBind (PTuple [PVar "a", PVar "b"]) (EVar "pair"))] (EVar "y")+status: pass
+ test/Test/Fixtures/golden/expr/proc-parenthesized-bind-fallback.yaml view
@@ -0,0 +1,6 @@+extensions: [Arrows]+input: |+ proc x -> do { (Just y) <- f -< x; (z@(Just w)) <- g -< y; ((returnA -< w)) }+ast: |-+ EProc (PVar "x") (CmdDo [DoBind (PParen (PCon "Just" [PVar "y"])) (CmdArrApp (EVar "f") HsFirstOrderApp (EVar "x")), DoBind (PParen (PAs UnqualifiedName {"z"} (PParen (PCon "Just" [PVar "w"])))) (CmdArrApp (EVar "g") HsFirstOrderApp (EVar "y")), DoExpr (CmdPar (CmdPar (CmdArrApp (EVar "returnA") HsFirstOrderApp (EVar "w"))))])+status: pass
+ test/Test/Fixtures/golden/pattern/list-pattern-fallback.yaml view
@@ -0,0 +1,6 @@+extensions: [BangPatterns, ViewPatterns]+input: |+ [K !x, K ~y, z@(Just w), id -> [a, b]]+ast: |-+ PList [PCon "K" [PStrict (PVar "x")], PCon "K" [PIrrefutable (PVar "y")], PAs UnqualifiedName {"z"} (PParen (PCon "Just" [PVar "w"])), PView (EVar "id") (PList [PVar "a", PVar "b"])]+status: pass
+ test/Test/Fixtures/golden/pattern/record-pattern-fallback.yaml view
@@ -0,0 +1,6 @@+extensions: [BangPatterns, ViewPatterns]+input: |+ Box {first = [[x]], second = id -> K !y, third = z@(Just w)}+ast: |-+ PRecord "Box" {"first" = PList [PList [PVar "x"]], "second" = PView (EVar "id") (PCon "K" [PStrict (PVar "y")]), "third" = PAs UnqualifiedName {"z"} (PParen (PCon "Just" [PVar "w"]))}+status: pass
+ test/Test/Fixtures/oracle/TypeApplications/at-operator-in-parens.hs view
@@ -0,0 +1,22 @@+{- ORACLE_TEST pass -}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+module AtOperatorInParens where++-- Regression test: '(@)' is an ordinary parenthesized varsym.+--+-- A tight '@' (no preceding whitespace) lexes as TkReservedAt, and+-- operatorExprNameParser used to reject that token, so '(@)' failed to parse+-- even though GHC accepts it and only rejects it later, in the renamer.+-- The pretty-printer already rendered EVar '@' as '(@)', so any generated AST+-- containing that name failed to round-trip.++f = (@)++g = (@) 1 2++h = (@ ())++i = $(@)++j x = x @Int
test/Test/Performance/Suite.hs view
@@ -6,7 +6,7 @@ where import Aihc.Parser-import Aihc.Parser.Syntax (Extension, parseExtensionName)+import Aihc.Parser.Syntax (Extension (Arrows, PatternSynonyms, RecursiveDo, ViewPatterns), parseExtensionName) import Control.DeepSeq (force) import Control.Exception (evaluate) import Data.Aeson ((.!=), (.:), (.:?))@@ -43,6 +43,22 @@ generatedCaseSize :: Int generatedCaseSize = 200 +-- | Depth for nested list-pattern cases. Keep the source below 10KiB.+listPatternSize :: Int+listPatternSize = 4000++-- | Depth for nested record-pattern cases. Keep the source below 10KiB.+recordPatternSize :: Int+recordPatternSize = 2000++-- | Depth for nested view-pattern cases. Keep the source below 10KiB.+viewPatternSize :: Int+viewPatternSize = 1200++-- | Depth for nested proc-do command parentheses. Keep the source below 10KiB.+procDoParenSize :: Int+procDoParenSize = 2000+ parserPerformanceTests :: IO TestTree parserPerformanceTests = do fixtureCases <- loadPerfCases@@ -96,13 +112,14 @@ } (perfCaseInput perfCase) case (perfCaseStatus perfCase, outcome) of- (StatusPass, Nothing) ->- assertFailure- ( "module parse exceeded "- <> show timeoutMicros- <> "us for "- <> perfCaseId perfCase- )+ (status, Nothing)+ | status /= StatusXFail ->+ assertFailure+ ( "module parse exceeded "+ <> show timeoutMicros+ <> "us for "+ <> perfCaseId perfCase+ ) (StatusPass, Just (errs, _)) | not (null errs) -> assertFailure@@ -111,6 +128,8 @@ <> ", got parse error: " <> formatParseErrors (perfCaseSourceName perfCase) (Just (perfCaseInput perfCase)) errs )+ (StatusFail, Just (errs, _))+ | null errs -> assertFailure ("expected parse failure for performance case " <> perfCaseId perfCase) (StatusXFail, Nothing) -> pure () (StatusXFail, Just (errs, _)) | null errs ->@@ -175,6 +194,7 @@ parseStatus fixturePath raw = case map toLower (T.unpack (T.strip raw)) of "pass" -> Right StatusPass+ "fail" -> Right StatusFail "xfail" -> Right StatusXFail _ -> Left ("Invalid [status] in " <> fixturePath <> ": " <> T.unpack raw) @@ -220,7 +240,173 @@ mkGeneratedPerfCase "type-parameters" (mkTypeModule (typeWithParameters generatedCaseSize)), 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"+ mkGeneratedPerfCaseWithStatus "invalid-module" "module Generated where\nvalue = { x = 1, }\n" StatusFail "",+ -- Nested block expressions must not be parsed again as patterns.+ mkGeneratedPerfCase "nested-paren-do" (mkExprModule (nestedParenDoExpr generatedCaseSize)),+ mkGeneratedPerfCase "nested-paren-do-case" (mkExprModule (nestedParenDoCaseExpr generatedCaseSize)),+ mkGeneratedPerfCase "nested-paren-do-if" (mkExprModule (nestedParenDoIfExpr generatedCaseSize)),+ mkGeneratedPerfCase "nested-paren-do-lambda" (mkExprModule (nestedParenDoLambdaExpr generatedCaseSize)),+ mkGeneratedPerfCase "nested-paren-do-let" (mkExprModule (nestedParenDoLetExpr generatedCaseSize)),+ mkGeneratedPerfCase "nested-paren-do-comp" (mkCompModule (nestedParenDoExpr generatedCaseSize)),+ mkGeneratedPerfCase "nested-paren-do-guard" (mkGuardModule (nestedParenDoExpr generatedCaseSize)),+ mkGeneratedPerfCase+ "nested-paren-do-bind"+ (mkExprModule (nestedWrap "do { x <- (" "); pure x }" "pure 1" generatedCaseSize)),+ mkGeneratedPerfCaseFull+ "nested-paren-mdo"+ generatedCaseSize+ [RecursiveDo]+ (mkExprModule ("mdo { (" <> nestedParenDoExpr generatedCaseSize <> ") }"))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "malformed-nested-proc-do-blocks"+ generatedCaseSize+ [Arrows]+ (mkProcModule (nestedParenDoExpr generatedCaseSize))+ StatusFail+ "",+ mkGeneratedPerfCaseFull+ "nested-proc-do-blocks"+ generatedCaseSize+ [Arrows]+ (mkProcModule (nestedWrap "do { (" ") }" "returnA -< x" generatedCaseSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "malformed-nested-let"+ generatedCaseSize+ []+ (mkExprModule (malformedNestedLetExpr generatedCaseSize))+ StatusFail+ "",+ -- Nested patterns must reuse the expression parse.+ mkGeneratedPerfCaseFull+ "nested-list-pattern"+ listPatternSize+ []+ (mkTuplePatternFunctionModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-bind"+ listPatternSize+ []+ (mkPatBindModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-case"+ listPatternSize+ []+ (mkCaseModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-lambda"+ listPatternSize+ []+ (mkLambdaModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-do"+ listPatternSize+ []+ (mkDoStmtModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-guard"+ listPatternSize+ []+ (mkGuardModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-comp"+ listPatternSize+ []+ (mkCompModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-where"+ listPatternSize+ []+ (mkWherePatModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-pattern-synonym"+ listPatternSize+ [PatternSynonyms]+ (mkPatSynModule (nestedListPattern listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-list-tuple-pattern"+ listPatternSize+ []+ (mkTuplePatternFunctionModule (nestedWrap "[" "]" "(x, y)" listPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-record-pattern"+ recordPatternSize+ []+ (mkTuplePatternFunctionModule (nestedRecordPattern recordPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-record-pattern-bind"+ recordPatternSize+ []+ (mkPatBindModule (nestedRecordPattern recordPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-record-pattern-case"+ recordPatternSize+ []+ (mkCaseModule (nestedRecordPattern recordPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-record-pattern-lambda"+ recordPatternSize+ []+ (mkLambdaModule (nestedRecordPattern recordPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-view-pattern"+ viewPatternSize+ [ViewPatterns]+ (mkTuplePatternFunctionModule (nestedViewPattern viewPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-view-pattern-bind"+ viewPatternSize+ [ViewPatterns]+ (mkPatBindModule (nestedViewPattern viewPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-view-pattern-case"+ viewPatternSize+ [ViewPatterns]+ (mkCaseModule (nestedViewPattern viewPatternSize))+ StatusPass+ "",+ mkGeneratedPerfCaseFull+ "nested-proc-do-parens"+ procDoParenSize+ [Arrows]+ (mkProcModule ("do { " <> nestedWrap "(" ")" "returnA -< x" procDoParenSize <> " }"))+ StatusPass+ "" ] mkGeneratedPerfCase :: String -> Text -> PerfCase@@ -228,12 +414,16 @@ mkGeneratedPerfCaseWithStatus label inputText StatusPass "" mkGeneratedPerfCaseWithStatus :: String -> Text -> ExpectedStatus -> String -> PerfCase-mkGeneratedPerfCaseWithStatus label inputText status reason =- let caseId = "generated/" <> label <> "-" <> show generatedCaseSize <> ".hs"+mkGeneratedPerfCaseWithStatus label =+ mkGeneratedPerfCaseFull label generatedCaseSize []++mkGeneratedPerfCaseFull :: String -> Int -> [Extension] -> Text -> ExpectedStatus -> String -> PerfCase+mkGeneratedPerfCaseFull label size exts inputText status reason =+ let caseId = "generated/" <> label <> "-" <> show size <> ".hs" in PerfCase { perfCaseId = caseId, perfCaseSourceName = caseId,- perfCaseExtensions = [],+ perfCaseExtensions = exts, perfCaseInput = inputText, perfCaseStatus = status, perfCaseReason = reason@@ -253,6 +443,65 @@ mkDataModule :: Text -> Text mkDataModule decl = T.unlines ["module Generated where", decl]++mkPatBindModule :: Text -> Text+mkPatBindModule pat = T.unlines ["module Generated where", pat <> " = ()"]++mkCaseModule :: Text -> Text+mkCaseModule pat = T.unlines ["module Generated where", "fn v = case v of", " " <> pat <> " -> ()"]++mkLambdaModule :: Text -> Text+mkLambdaModule pat = T.unlines ["module Generated where", "fn = \\" <> pat <> " -> ()"]++mkDoStmtModule :: Text -> Text+mkDoStmtModule stmt = T.unlines ["module Generated where", "fn = do", " " <> stmt, " pure ()"]++mkGuardModule :: Text -> Text+mkGuardModule guard = T.unlines ["module Generated where", "fn | " <> guard <> " = ()"]++mkCompModule :: Text -> Text+mkCompModule qual = T.unlines ["module Generated where", "fn = [() | " <> qual <> "]"]++mkWherePatModule :: Text -> Text+mkWherePatModule pat = T.unlines ["module Generated where", "fn = ()", " where", " " <> pat <> " = ()"]++mkPatSynModule :: Text -> Text+mkPatSynModule pat = T.unlines ["module Generated where", "pattern P = " <> pat]++mkProcModule :: Text -> Text+mkProcModule cmd = T.unlines ["module Generated where", "fn = proc x -> " <> cmd]++-- | Wrap an inner term in @n@ copies of an open/close pair.+nestedWrap :: Text -> Text -> Text -> Int -> Text+nestedWrap open close inner n =+ T.concat (replicate n open) <> inner <> T.concat (replicate n close)++nestedParenDoExpr :: Int -> Text+nestedParenDoExpr = nestedWrap "do { (" ") }" "pure 1"++nestedParenDoCaseExpr :: Int -> Text+nestedParenDoCaseExpr = nestedWrap "do { (case x of { _ -> " " }) }" "1"++nestedParenDoIfExpr :: Int -> Text+nestedParenDoIfExpr = nestedWrap "do { (if True then " " else 0) }" "1"++nestedParenDoLambdaExpr :: Int -> Text+nestedParenDoLambdaExpr = nestedWrap "do { (\\x -> " ") }" "x"++nestedParenDoLetExpr :: Int -> Text+nestedParenDoLetExpr = nestedWrap "do { (let x = " " in x) }" "1"++malformedNestedLetExpr :: Int -> Text+malformedNestedLetExpr n = nestedWrap "let x = " " in " "1" n <> "x"++nestedListPattern :: Int -> Text+nestedListPattern = nestedWrap "[" "]" "x"++nestedRecordPattern :: Int -> Text+nestedRecordPattern = nestedWrap "T{x=" "}" "y"++nestedViewPattern :: Int -> Text+nestedViewPattern = nestedWrap "(id -> " ")" "x" nestedTupleExpr :: Int -> Text nestedTupleExpr n =