diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,28 @@ ## [Unreleased] +## [1.0.0.4] - 2026-07-26 + +### Added + +- Added `Addr#` literal syntax and expanded GHC layout oracle coverage. +- Added a developer-only public fuzz registry for downstream property suites. +- Added a `Read` instance for `FixityAssoc` so downstream metadata containing + operator fixities can be persisted and restored. + +### Changed + +- Improved parser throughput and reduced allocations across large Stackage + inputs and deeply nested syntax. +- Moved development to the standalone + [`ai-haskell-compiler/aihc-parser`](https://github.com/ai-haskell-compiler/aihc-parser) + repository, including the full test, progress, doctest, fuzz, and + compatibility CI configuration. + +### Fixed + +- Aligned multiline `case` scrutinee layout with GHC. + ## [1.0.0.3] - 2026-06-01 ### Changed diff --git a/aihc-parser.cabal b/aihc-parser.cabal --- a/aihc-parser.cabal +++ b/aihc-parser.cabal @@ -1,11 +1,12 @@ cabal-version: 3.8 name: aihc-parser -version: 1.0.0.3 +version: 1.0.0.4 build-type: Simple license: Unlicense license-file: LICENSE extra-doc-files: CHANGELOG.md extra-source-files: + docs/aihc-parser-supported-extensions.md test/Test/Fixtures/**/*.hs test/Test/Fixtures/**/*.yaml @@ -24,17 +25,22 @@ The package is validated with golden tests and oracle-backed differential tests against GHC. -homepage: https://github.com/ai-haskell-compiler/aihc/tree/main/components/aihc-parser -bug-reports: https://github.com/ai-haskell-compiler/aihc/issues +homepage: https://github.com/ai-haskell-compiler/aihc-parser +bug-reports: https://github.com/ai-haskell-compiler/aihc-parser/issues source-repository head type: git - location: https://github.com/ai-haskell-compiler/aihc.git - subdir: components/aihc-parser + location: https://github.com/ai-haskell-compiler/aihc-parser.git +flag fuzz + description: Build the developer-only QuickCheck property registry + default: False + manual: True + library exposed-modules: Aihc.Parser + Aihc.Parser.Internal.Testing Aihc.Parser.Parens Aihc.Parser.Pretty Aihc.Parser.Shorthand @@ -76,6 +82,58 @@ ghc-options: -Wall default-language: GHC2021 +library fuzz + if !flag(fuzz) + buildable: False + visibility: public + hs-source-dirs: + fuzz + test + common + + exposed-modules: + Aihc.Parser.Fuzz + Test.Properties.Arb.Decl + Test.Properties.Arb.Expr + Test.Properties.Arb.Identifiers + Test.Properties.Arb.Module + Test.Properties.Arb.Pattern + Test.Properties.Arb.Type + Test.Properties.Arb.Utils + + other-modules: + CppSupport + GhcOracle + ParserValidation + Test.Properties.Coverage + Test.Properties.DeclRoundTrip + Test.Properties.ExprRoundTrip + Test.Properties.MinimalParentheses + Test.Properties.ModuleRoundTrip + Test.Properties.NoExceptions + Test.Properties.ParensIdempotency + Test.Properties.PatternRoundTrip + Test.Properties.ShorthandSubset + Test.Properties.TypeRoundTrip + + build-depends: + Diff >=1.0 && <1.1, + QuickCheck >=2.14 && <2.19, + aihc-cpp >=1.0 && <1.1, + aihc-hackage >=0.1 && <0.2, + aihc-parser, + base >=4.19 && <5, + bytestring >=0.10.8 && <0.13, + containers >=0.5 && <0.9, + deepseq >=1.4 && <1.6, + filepath >=1.3.0.1 && <1.6, + ghc-lib-parser >=9.14.1 && <9.15, + prettyprinter >=1.7 && <1.8, + text >=2.1.2 && <2.2, + + ghc-options: -Wall + default-language: GHC2021 + test-suite spec type: exitcode-stdio-1.0 hs-source-dirs: @@ -96,6 +154,7 @@ Aihc.Parser.Internal.Import Aihc.Parser.Internal.Module Aihc.Parser.Internal.Pattern + Aihc.Parser.Internal.Testing Aihc.Parser.Internal.Type Aihc.Parser.Lex Aihc.Parser.Lex.Header diff --git a/docs/aihc-parser-supported-extensions.md b/docs/aihc-parser-supported-extensions.md new file mode 100644 --- /dev/null +++ b/docs/aihc-parser-supported-extensions.md @@ -0,0 +1,97 @@ +# Haskell Parser Extension Support Status + +## Summary + +- Total Extensions: 84 +- Supported: 84 +- In Progress: 0 + +## Extension Status + +| Extension | Status | Tests Passing | +|---------------------------|:------:|---------------| +| Arrows | 🟢 | 30/30 | +| BangPatterns | 🟢 | 13/13 | +| BinaryLiterals | 🟢 | 3/3 | +| BlockArguments | 🟢 | 13/13 | +| CApiFFI | 🟢 | 4/4 | +| CPP | 🟢 | 8/8 | +| ConstraintKinds | 🟢 | 8/8 | +| DataKinds | 🟢 | 65/65 | +| DefaultSignatures | 🟢 | 4/4 | +| DerivingStrategies | 🟢 | 8/8 | +| DerivingVia | 🟢 | 7/7 | +| DoAndIfThenElse | 🟢 | 15/15 | +| DoRec | 🟢 | 1/1 | +| EmptyCase | 🟢 | 7/7 | +| EmptyDataDecls | 🟢 | 8/8 | +| EmptyDataDeriving | 🟢 | 4/4 | +| ExistentialQuantification | 🟢 | 7/7 | +| ExplicitForAll | 🟢 | 27/27 | +| ExplicitLevelImports | 🟢 | 4/4 | +| ExplicitNamespaces | 🟢 | 26/26 | +| ExtendedLiterals | 🟢 | 4/4 | +| FlexibleContexts | 🟢 | 4/4 | +| FlexibleInstances | 🟢 | 18/18 | +| ForeignFunctionInterface | 🟢 | 40/40 | +| FunctionalDependencies | 🟢 | 7/7 | +| GADTSyntax | 🟢 | 11/11 | +| GADTs | 🟢 | 15/15 | +| GHC2021 | 🟢 | 44/44 | +| GHCForeignImportPrim | 🟢 | 1/1 | +| Haskell2010 | 🟢 | 17/17 | +| HexFloatLiterals | 🟢 | 3/3 | +| ImplicitParams | 🟢 | 11/11 | +| ImportQualifiedPost | 🟢 | 5/5 | +| InstanceSigs | 🟢 | 5/5 | +| InterruptibleFFI | 🟢 | 1/1 | +| JavaScriptFFI | 🟢 | 1/1 | +| KindSignatures | 🟢 | 33/33 | +| LambdaCase | 🟢 | 23/23 | +| LinearTypes | 🟢 | 15/15 | +| MagicHash | 🟢 | 24/24 | +| MultiParamTypeClasses | 🟢 | 24/24 | +| MultiWayIf | 🟢 | 21/21 | +| MultilineStrings | 🟢 | 6/6 | +| NamedFieldPuns | 🟢 | 6/6 | +| NamedWildCards | 🟢 | 5/5 | +| NegativeLiterals | 🟢 | 1/1 | +| NondecreasingIndentation | 🟢 | 3/3 | +| NumericUnderscores | 🟢 | 4/4 | +| OverlappingInstances | 🟢 | 1/1 | +| OverloadedLabels | 🟢 | 6/6 | +| OverloadedRecordDot | 🟢 | 8/8 | +| PackageImports | 🟢 | 6/6 | +| ParallelListComp | 🟢 | 3/3 | +| PartialTypeSignatures | 🟢 | 21/21 | +| PatternGuards | 🟢 | 9/9 | +| PatternSynonyms | 🟢 | 34/34 | +| PolyKinds | 🟢 | 14/14 | +| QualifiedDo | 🟢 | 4/4 | +| QuantifiedConstraints | 🟢 | 2/2 | +| QuasiQuotes | 🟢 | 11/11 | +| RankNTypes | 🟢 | 5/5 | +| RecordWildCards | 🟢 | 10/10 | +| RecursiveDo | 🟢 | 5/5 | +| RequiredTypeArguments | 🟢 | 4/4 | +| RoleAnnotations | 🟢 | 7/7 | +| Safe | 🟢 | 2/2 | +| ScopedTypeVariables | 🟢 | 18/18 | +| StandaloneDeriving | 🟢 | 18/18 | +| StandaloneKindSignatures | 🟢 | 12/12 | +| StarIsType | 🟢 | 4/4 | +| TemplateHaskell | 🟢 | 68/68 | +| TemplateHaskellQuotes | 🟢 | 14/14 | +| TransformListComp | 🟢 | 18/18 | +| TupleSections | 🟢 | 4/4 | +| TypeAbstractions | 🟢 | 5/5 | +| TypeApplications | 🟢 | 13/13 | +| TypeData | 🟢 | 1/1 | +| TypeFamilies | 🟢 | 61/61 | +| TypeFamilyDependencies | 🟢 | 4/4 | +| TypeOperators | 🟢 | 71/71 | +| UnboxedSums | 🟢 | 13/13 | +| UnboxedTuples | 🟢 | 22/22 | +| UnicodeSyntax | 🟢 | 21/21 | +| ViewPatterns | 🟢 | 26/26 | + diff --git a/fuzz/Aihc/Parser/Fuzz.hs b/fuzz/Aihc/Parser/Fuzz.hs new file mode 100644 --- /dev/null +++ b/fuzz/Aihc/Parser/Fuzz.hs @@ -0,0 +1,64 @@ +-- | Continuously runnable QuickCheck properties owned by @aihc-parser@. +module Aihc.Parser.Fuzz + ( parserFuzzProperties, + ) +where + +import Test.Properties.DeclRoundTrip (prop_declPrettyRoundTrip) +import Test.Properties.ExprRoundTrip (prop_exprPrettyRoundTrip) +import Test.Properties.MinimalParentheses (prop_minimalParenthesesExpr, prop_minimalParenthesesPattern, prop_minimalParenthesesSignatureType, prop_minimalParenthesesType) +import Test.Properties.ModuleRoundTrip (prop_modulePrettyRoundTrip, prop_moduleValidator) +import Test.Properties.NoExceptions + ( prop_declParserArbitraryTokensNoExceptions, + prop_exprParserArbitraryTokensNoExceptions, + prop_genLexTokenKindConstructorCoverage, + prop_importDeclParserArbitraryTokensNoExceptions, + prop_lexerArbitraryTextNoExceptions, + prop_moduleHeaderParserArbitraryTokensNoExceptions, + prop_moduleParserArbitraryTokensNoExceptions, + prop_patternParserArbitraryTokensNoExceptions, + prop_preprocessorArbitraryTextNoExceptions, + prop_typeParserArbitraryTokensNoExceptions, + ) +import Test.Properties.ParensIdempotency (prop_declParensIdempotent, prop_exprParensIdempotent, prop_moduleParensIdempotent, prop_patternParensIdempotent, prop_typeParensIdempotent) +import Test.Properties.PatternRoundTrip (prop_patternPrettyRoundTrip) +import Test.Properties.ShorthandSubset (prop_shorthandDeclSubsetOfShow, prop_shorthandExprSubsetOfShow, prop_shorthandLexTokenSubsetOfShow, prop_shorthandModuleSubsetOfShow, prop_shorthandTypeSubsetOfShow) +import Test.Properties.TypeRoundTrip (prop_typePrettyRoundTrip) +import Test.QuickCheck (Property, Testable, property) + +parserFuzzProperties :: [(String, Property)] +parserFuzzProperties = + [ named "expr paren insertion is minimal" prop_minimalParenthesesExpr, + named "pattern paren insertion is minimal" prop_minimalParenthesesPattern, + named "signature type paren insertion is minimal" prop_minimalParenthesesSignatureType, + named "type paren insertion is minimal" prop_minimalParenthesesType, + named "generated expr AST pretty-printer round-trip" prop_exprPrettyRoundTrip, + named "generated decl AST pretty-printer round-trip" prop_declPrettyRoundTrip, + named "generated module AST pretty-printer round-trip" prop_modulePrettyRoundTrip, + named "generated module AST validator" prop_moduleValidator, + named "generated pattern AST pretty-printer round-trip" prop_patternPrettyRoundTrip, + named "generated type AST pretty-printer round-trip" prop_typePrettyRoundTrip, + named "module paren insertion is idempotent" prop_moduleParensIdempotent, + named "decl paren insertion is idempotent" prop_declParensIdempotent, + named "expr paren insertion is idempotent" prop_exprParensIdempotent, + named "pattern paren insertion is idempotent" prop_patternParensIdempotent, + named "type paren insertion is idempotent" prop_typeParensIdempotent, + named "module shorthand is a subset of Show" prop_shorthandModuleSubsetOfShow, + named "decl shorthand is a subset of Show" prop_shorthandDeclSubsetOfShow, + named "expr shorthand is a subset of Show" prop_shorthandExprSubsetOfShow, + named "type shorthand is a subset of Show" prop_shorthandTypeSubsetOfShow, + named "lex token shorthand is a subset of Show" prop_shorthandLexTokenSubsetOfShow, + named "lex token kind generator covers constructors" prop_genLexTokenKindConstructorCoverage, + named "no exceptions.preprocessor accepts arbitrary text" prop_preprocessorArbitraryTextNoExceptions, + named "no exceptions.lexer accepts arbitrary text" prop_lexerArbitraryTextNoExceptions, + named "no exceptions.module parser accepts arbitrary tokens" prop_moduleParserArbitraryTokensNoExceptions, + named "no exceptions.expr parser accepts arbitrary tokens" prop_exprParserArbitraryTokensNoExceptions, + named "no exceptions.type parser accepts arbitrary tokens" prop_typeParserArbitraryTokensNoExceptions, + named "no exceptions.pattern parser accepts arbitrary tokens" prop_patternParserArbitraryTokensNoExceptions, + named "no exceptions.decl parser accepts arbitrary tokens" prop_declParserArbitraryTokensNoExceptions, + named "no exceptions.import decl parser accepts arbitrary tokens" prop_importDeclParserArbitraryTokensNoExceptions, + named "no exceptions.module header parser accepts arbitrary tokens" prop_moduleHeaderParserArbitraryTokensNoExceptions + ] + where + named :: (Testable prop) => String -> prop -> (String, Property) + named name value = (name, property value) diff --git a/src/Aihc/Parser/Internal/CheckPattern.hs b/src/Aihc/Parser/Internal/CheckPattern.hs --- a/src/Aihc/Parser/Internal/CheckPattern.hs +++ b/src/Aihc/Parser/Internal/CheckPattern.hs @@ -20,7 +20,7 @@ ) where -import Aihc.Parser.Internal.Common (isConLikeName) +import Aihc.Parser.Internal.Common (isConLikeName, nameToUnqualified) import Aihc.Parser.Syntax import Data.Maybe (isJust, isNothing) import Data.Text (Text) @@ -37,7 +37,7 @@ | nameText name == "_" -> Right PWildcard | isConLikeName name -> Right (PCon name [] []) | isJust (nameQualifier name) -> Left "unexpected qualified name in pattern" - | otherwise -> Right (PVar (mkUnqualifiedName (nameType name) (nameText name))) + | otherwise -> Right (PVar (nameToUnqualified name)) ETypeSyntax form ty -> Right (PTypeSyntax form ty) -- Parenthesized expression -- When the inner expression is a view-pattern arrow (@expr -> expr@), diff --git a/src/Aihc/Parser/Internal/Common.hs b/src/Aihc/Parser/Internal/Common.hs --- a/src/Aihc/Parser/Internal/Common.hs +++ b/src/Aihc/Parser/Internal/Common.hs @@ -11,6 +11,10 @@ hiddenPragma, optionalHiddenPragma, moduleNameParser, + nameToUnqualified, + mkUnqualifiedNameAt, + mkNameAt, + identifierNameWithTokenParser, identifierNameParser, identifierUnqualifiedNameParser, identifierTextParser, @@ -27,6 +31,7 @@ operatorTextParser, constructorInfixOperatorNameParser, stringTextParser, + inputStartSpan, withSpan, withSpanAnn, optionalSuffix, @@ -71,7 +76,7 @@ import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), closeImplicitLayoutContext) import Aihc.Parser.Syntax -import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken) +import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, tokStreamExtensionSet) import Control.Monad (guard) import Data.Char (isUpper) import Data.Functor (($>)) @@ -132,6 +137,7 @@ expectedTok expected = tokenSatisfy (renderTokenKind expected) $ \tok -> if lexTokenKind tok == expected then Just () else Nothing +{-# INLINE expectedTok #-} -- | Match the end-of-file token. -- @@ -224,6 +230,7 @@ if null expectedLabel then MPE.EndOfInput else MPE.Label (NE.fromList expectedLabel) +{-# INLINE tokenSatisfy #-} hiddenPragma :: String -> (Pragma -> Maybe a) -> TokParser a hiddenPragma expectedLabel f = do @@ -267,22 +274,26 @@ TkQConId modName name | isModuleName (modName <> "." <> name) -> Just (modName <> "." <> name) _ -> Nothing -identifierNameParser :: TokParser Name -identifierNameParser = +identifierNameWithTokenParser :: TokParser (LexToken, Name) +identifierNameWithTokenParser = tokenSatisfy "identifier" $ \tok -> case lexTokenKind tok of - TkVarId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId ident)) - TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameConId ident)) - TkQVarId modName ident -> Just (mkName (Just modName) NameVarId ident) - TkQConId modName ident -> Just (mkName (Just modName) NameConId ident) + TkVarId ident -> Just (tok, qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId ident)) + TkConId ident -> Just (tok, qualifyName Nothing (mkUnqualifiedNameAt tok NameConId ident)) + TkQVarId modName ident -> Just (tok, mkNameAt tok (Just modName) NameVarId ident) + TkQConId modName ident -> Just (tok, mkNameAt tok (Just modName) NameConId ident) _ -> Nothing +identifierNameParser :: TokParser Name +identifierNameParser = + snd <$> identifierNameWithTokenParser + identifierUnqualifiedNameParser :: TokParser UnqualifiedName identifierUnqualifiedNameParser = tokenSatisfy "unqualified identifier" $ \tok -> case lexTokenKind tok of - TkVarId ident -> Just (mkUnqualifiedName NameVarId ident) - TkConId ident -> Just (mkUnqualifiedName NameConId ident) + TkVarId ident -> Just (mkUnqualifiedNameAt tok NameVarId ident) + TkConId ident -> Just (mkUnqualifiedNameAt tok NameConId ident) _ -> Nothing identifierTextParser :: TokParser Text @@ -312,33 +323,29 @@ constructorNameParser = tokenSatisfy "constructor identifier" $ \tok -> case lexTokenKind tok of - TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedName NameConId ident)) - TkQConId modName ident -> Just (mkName (Just modName) NameConId ident) + TkConId ident -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId ident)) + TkQConId modName ident -> Just (mkNameAt tok (Just modName) NameConId ident) _ -> Nothing constructorUnqualifiedNameParser :: TokParser UnqualifiedName constructorUnqualifiedNameParser = tokenSatisfy "unqualified constructor identifier" $ \tok -> case lexTokenKind tok of - TkConId ident -> Just (mkUnqualifiedName NameConId ident) + TkConId ident -> Just (mkUnqualifiedNameAt tok NameConId ident) _ -> Nothing constructorOperatorUnqualifiedNameParser :: TokParser UnqualifiedName constructorOperatorUnqualifiedNameParser = tokenSatisfy "unqualified constructor operator" $ \tok -> case lexTokenKind tok of - TkConSym op -> Just (mkUnqualifiedName NameConSym op) - TkReservedColon -> Just (mkUnqualifiedName NameConSym ":") + TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op) + TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":") _ -> Nothing binderNameParser :: TokParser UnqualifiedName binderNameParser = - spanned identifierUnqualifiedNameParser - <|> parens (spanned operatorUnqualifiedNameParser) - where - spanned = - withSpanAnn $ \sp name -> - name {unqualifiedNameAnns = mkAnnotation sp : unqualifiedNameAnns name} + identifierUnqualifiedNameParser + <|> parens operatorUnqualifiedNameParser recordFieldNameParser :: TokParser Name recordFieldNameParser = @@ -352,28 +359,28 @@ operatorNameParser = tokenSatisfy "operator" $ \tok -> case lexTokenKind tok of - TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op)) - TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op)) - TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op) - TkQConSym modName op -> Just (mkName (Just modName) NameConSym op) - TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "@")) + TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op)) + TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op)) + TkQVarSym modName op -> Just (mkNameAt tok (Just modName) NameVarSym op) + TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op) + TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "@")) _ -> Nothing operatorUnqualifiedNameParser :: TokParser UnqualifiedName operatorUnqualifiedNameParser = tokenSatisfy "unqualified operator" $ \tok -> case lexTokenKind tok of - TkVarSym op -> Just (mkUnqualifiedName NameVarSym op) - TkConSym op -> Just (mkUnqualifiedName NameConSym op) - TkReservedRightArrow -> Just (mkUnqualifiedName NameVarSym "->") - TkReservedLeftArrow -> Just (mkUnqualifiedName NameVarSym "<-") - TkReservedDoubleArrow -> Just (mkUnqualifiedName NameVarSym "=>") - TkReservedEquals -> Just (mkUnqualifiedName NameVarSym "=") - TkReservedPipe -> Just (mkUnqualifiedName NameVarSym "|") - TkReservedDotDot -> Just (mkUnqualifiedName NameVarSym "..") - TkReservedDoubleColon -> Just (mkUnqualifiedName NameVarSym "::") - TkReservedColon -> Just (mkUnqualifiedName NameConSym ":") - TkReservedAt -> Just (mkUnqualifiedName NameVarSym "@") + TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op) + TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op) + TkReservedRightArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "->") + TkReservedLeftArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "<-") + TkReservedDoubleArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "=>") + TkReservedEquals -> Just (mkUnqualifiedNameAt tok NameVarSym "=") + TkReservedPipe -> Just (mkUnqualifiedNameAt tok NameVarSym "|") + TkReservedDotDot -> Just (mkUnqualifiedNameAt tok NameVarSym "..") + TkReservedDoubleColon -> Just (mkUnqualifiedNameAt tok NameVarSym "::") + TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":") + TkReservedAt -> Just (mkUnqualifiedNameAt tok NameVarSym "@") _ -> Nothing -- | Parse an infix operator name (varop) for function definitions. @@ -390,17 +397,17 @@ symbolicOperatorParser = tokenSatisfy "variable operator" $ \tok -> case lexTokenKind tok of - TkVarSym op -> Just (mkUnqualifiedName NameVarSym op) + TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op) _ -> Nothing backtickIdentifierParser = do expectedTok TkSpecialBacktick - op <- varIdTextParser + op <- varIdNameParser expectedTok TkSpecialBacktick - pure (mkUnqualifiedName NameVarId op) - varIdTextParser = + pure op + varIdNameParser = tokenSatisfy "variable identifier" $ \tok -> case lexTokenKind tok of - TkVarId name -> Just name + TkVarId name -> Just (mkUnqualifiedNameAt tok NameVarId name) _ -> Nothing -- | Parse an infix constructor operator name (conop) for pattern synonym where clauses. @@ -415,20 +422,32 @@ symbolicConstructorOperatorParser = tokenSatisfy "constructor operator" $ \tok -> case lexTokenKind tok of - TkConSym op -> Just (mkUnqualifiedName NameConSym op) - TkReservedColon -> Just (mkUnqualifiedName NameConSym ":") + TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op) + TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":") _ -> Nothing backtickConstructorIdentifierParser = do expectedTok TkSpecialBacktick - op <- constructorIdentifierTextParser + op <- constructorIdentifierNameParser expectedTok TkSpecialBacktick - pure (mkUnqualifiedName NameConId op) - constructorIdentifierTextParser = + pure op + constructorIdentifierNameParser = tokenSatisfy "constructor identifier" $ \tok -> case lexTokenKind tok of - TkConId name -> Just name + TkConId name -> Just (mkUnqualifiedNameAt tok NameConId name) _ -> Nothing +mkUnqualifiedNameAt :: LexToken -> NameType -> Text -> UnqualifiedName +mkUnqualifiedNameAt tok ty txt = + UnqualifiedName ty txt [mkAnnotation (lexTokenSpan tok)] + +mkNameAt :: LexToken -> Maybe Text -> NameType -> Text -> Name +mkNameAt tok qualifier ty txt = + Name qualifier ty txt [mkAnnotation (lexTokenSpan tok)] + +nameToUnqualified :: Name -> UnqualifiedName +nameToUnqualified name = + UnqualifiedName (nameType name) (nameText name) (nameAnns name) + stringTextParser :: TokParser Text stringTextParser = tokenSatisfy "string literal" $ \tok -> @@ -438,33 +457,35 @@ withSpanAnn :: (SourceSpan -> a -> a) -> TokParser a -> TokParser a withSpanAnn f parser = do - ts <- fmap MP.stateInput MP.getParserState - let startSpan - | tokStreamEOFEmitted ts = noSourceSpan - | tok : _ <- layoutBuffer (tokStreamLayoutState ts) = lexTokenSpan tok - | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok - | otherwise = noSourceSpan + startInput <- MP.getInput out <- parser - lastToken <- fmap (tokStreamPrevToken . MP.stateInput) MP.getParserState - let endSpan = maybe noSourceSpan lexTokenSpan lastToken + endInput <- MP.getInput + let startSpan = inputStartSpan startInput + endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput) parserSpan = mergeSourceSpans startSpan endSpan pure $ f parserSpan out +{-# INLINE withSpanAnn #-} -- FIXME: Remove. withSpan :: TokParser (SourceSpan -> a) -> TokParser a withSpan parser = do - ts <- fmap MP.stateInput MP.getParserState - let startSpan - | tokStreamEOFEmitted ts = noSourceSpan - | tok : _ <- layoutBuffer (tokStreamLayoutState ts) = lexTokenSpan tok - | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok - | otherwise = noSourceSpan + startInput <- MP.getInput out <- parser - lastToken <- fmap (tokStreamPrevToken . MP.stateInput) MP.getParserState - let endSpan = maybe noSourceSpan lexTokenSpan lastToken + endInput <- MP.getInput + let startSpan = inputStartSpan startInput + endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput) parserSpan = mergeSourceSpans startSpan endSpan pure (out parserSpan) +{-# INLINE withSpan #-} +inputStartSpan :: TokStream -> SourceSpan +inputStartSpan ts + | tokStreamEOFEmitted ts = noSourceSpan + | tok : _ <- tokStreamBuffer ts = lexTokenSpan tok + | rawTok : _ <- tokStreamRawTokens ts = lexTokenSpan rawTok + | otherwise = noSourceSpan +{-# INLINE inputStartSpan #-} + optionalSuffix :: TokParser b -> (a -> b -> a) -> TokParser a -> TokParser a optionalSuffix suffixParser attach parser = do base <- parser @@ -638,8 +659,8 @@ constraintOperatorIdentifierParser = tokenSatisfy "constraint operator identifier" $ \tok -> case lexTokenKind tok of - TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId name)) - TkConId name -> Just (qualifyName Nothing (mkUnqualifiedName NameConId name)) + TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name)) + TkConId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId name)) _ -> Nothing unpromotedInfixOperatorParser = tokenSatisfy "type infix operator" $ \tok -> @@ -647,11 +668,11 @@ TkVarSym op | op /= "." && op /= "!" -> - Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op), Unpromoted) - TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op), Unpromoted) + Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op), Unpromoted) + TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op), Unpromoted) TkQVarSym modName op -> - Just (mkName (Just modName) NameVarSym op, Unpromoted) - TkQConSym modName op -> Just (mkName (Just modName) NameConSym op, Unpromoted) + Just (mkNameAt tok (Just modName) NameVarSym op, Unpromoted) + TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op, Unpromoted) _ -> Nothing promotedInfixOperatorParser = do expectedTok (TkVarSym "'") @@ -723,11 +744,46 @@ functionHeadParserWith = functionHeadParserWithBinder functionBinderNameParser infixOperatorNameParser functionHeadParserWithBinder :: TokParser UnqualifiedName -> TokParser UnqualifiedName -> TokParser Pattern -> TokParser Pattern -> TokParser (MatchHeadForm, UnqualifiedName, [Pattern]) -functionHeadParserWithBinder binderParser infixOpParser infixPatternParser prefixPatternParser = - MP.try parenthesizedInfixHeadParser - <|> MP.try infixHeadParser - <|> prefixHeadParser +functionHeadParserWithBinder binderParser infixOpParser infixPatternParser prefixPatternParser = do + (firstKind, secondKind) <- + lookAhead $ do + first <- lexTokenKind <$> anySingle + second <- lexTokenKind <$> anySingle + pure (first, second) + case firstKind of + TkVarId {} + | startsPrefixHead secondKind -> prefixHeadParser + | otherwise -> MP.try infixHeadParser <|> prefixHeadParser + TkSpecialLParen -> + MP.try parenthesizedInfixHeadParser + <|> MP.try infixHeadParser + <|> prefixHeadParser + _ -> infixHeadParser where + startsPrefixHead kind = + case kind of + TkVarId {} -> True + TkConId {} -> True + TkQConId {} -> True + TkInteger {} -> True + TkFloat {} -> True + TkChar {} -> True + TkCharHash {} -> True + TkString {} -> True + TkStringHash {} -> True + TkSpecialLParen -> True + TkSpecialUnboxedLParen -> True + TkSpecialLBracket -> True + TkKeywordUnderscore -> True + TkPrefixBang -> True + TkPrefixTilde -> True + TkPrefixMinus -> True + TkQuasiQuote {} -> True + TkTypeApp -> True + TkReservedEquals -> True + TkReservedPipe -> True + _ -> False + prefixHeadParser = do name <- binderParser pats <- MP.many prefixPatternParser @@ -755,13 +811,13 @@ variableIdentifierParser = tokenSatisfy "function binder" $ \tok -> case lexTokenKind tok of - TkVarId ident -> Just (mkUnqualifiedName NameVarId ident) + TkVarId ident -> Just (mkUnqualifiedNameAt tok NameVarId ident) _ -> Nothing variableOperatorParser = tokenSatisfy "variable operator" $ \tok -> case lexTokenKind tok of - TkVarSym ident -> Just (mkUnqualifiedName NameVarSym ident) - TkReservedAt -> Just (mkUnqualifiedName NameVarSym "@") + TkVarSym ident -> Just (mkUnqualifiedNameAt tok NameVarSym ident) + TkReservedAt -> Just (mkUnqualifiedNameAt tok NameVarSym "@") _ -> Nothing functionBindValue :: MatchHeadForm -> UnqualifiedName -> [Pattern] -> Rhs Expr -> ValueDecl @@ -798,9 +854,9 @@ Nothing -> False isExtensionEnabled :: Extension -> TokParser Bool -isExtensionEnabled ext = do - pst <- MP.getParserState - pure (ext `elem` tokStreamExtensions (MP.stateInput pst)) +isExtensionEnabled ext = + memberExtension ext . tokStreamExtensionSet <$> MP.getInput +{-# INLINE isExtensionEnabled #-} -- | Check whether any Template Haskell extension is enabled (quotes or full TH). thAnyEnabled :: TokParser Bool @@ -847,7 +903,19 @@ case closeImplicitLayoutContext (tokStreamLayoutState ts) of Nothing -> pure False Just laySt' -> do - MP.updateParserState (\s -> s {MP.stateInput = (MP.stateInput s) {tokStreamLayoutState = laySt'}}) + let inserted = layoutBuffer laySt' + laySt'' = laySt' {layoutBuffer = []} + MP.updateParserState + ( \s -> + let input = MP.stateInput s + in s + { MP.stateInput = + input + { tokStreamLayoutState = laySt'', + tokStreamBuffer = inserted <> tokStreamBuffer input + } + } + ) pure True -- | Like Megaparsec's 'MP.sepEndBy' but implements the parse-error rule for @@ -985,9 +1053,9 @@ sigOperatorParser = tokenSatisfy "signature operator" $ \tok -> case lexTokenKind tok of - TkVarSym op -> Just (mkUnqualifiedName NameVarSym op) - TkConSym op -> Just (mkUnqualifiedName NameConSym op) - TkReservedColon -> Just (mkUnqualifiedName NameConSym ":") + TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op) + TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op) + TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":") _ -> Nothing -- | Non-consuming lookahead: does the input start with @name \@@? @@ -1032,15 +1100,15 @@ symbolicOperatorParser = tokenSatisfy "infix operator" $ \tok -> case lexTokenKind tok of - TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op)) - TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op)) - TkPrefixPercent -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "%")) - TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op) - TkQConSym modName op -> Just (mkName (Just modName) NameConSym op) + TkVarSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op)) + TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op)) + TkPrefixPercent -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "%")) + TkQVarSym modName op -> Just (mkNameAt tok (Just modName) NameVarSym op) + TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op) -- TkMinusOperator is minus when LexicalNegation is enabled but used as infix - TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-")) + TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "-")) -- Reserved operators that can be used as infix operators - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) + TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":")) _ -> Nothing backtickIdentifierOperatorParser = diff --git a/src/Aihc/Parser/Internal/Decl.hs b/src/Aihc/Parser/Internal/Decl.hs --- a/src/Aihc/Parser/Internal/Decl.hs +++ b/src/Aihc/Parser/Internal/Decl.hs @@ -45,16 +45,25 @@ ordinaryDeclParser :: TokParser Decl ordinaryDeclParser = do (tok, nextTok) <- lookAhead ((,) <$> anySingle <*> anySingle) - exprFallback <- exprDeclEnabled - typeSigPrefix <- startsWithTypeSig let tokKind = lexTokenKind tok nextTokKind = lexTokenKind nextTok - valueDecl - | exprFallback = MP.try valueDeclParser <|> exprDeclParser - | otherwise = valueDeclParser - sigOrValueDecl - | typeSigPrefix = typeSigOrPatternTypeSigDeclParser - | otherwise = valueDecl + valueDecl = do + exprFallback <- exprDeclEnabled + if exprFallback + then MP.try valueDeclParser <|> exprDeclParser + else valueDeclParser + sigOrValueDecl = do + typeSigPrefix <- startsWithTypeSig + if typeSigPrefix + then typeSigOrPatternTypeSigDeclParser + else valueDecl + fallbackDecl = do + typeSigPrefix <- startsWithTypeSig + exprFallback <- exprDeclEnabled + (if typeSigPrefix then typeSigOrPatternTypeSigDeclParser else MP.empty) + <|> MP.try valueDeclParser + <|> patternBindDeclParser + <|> (if exprFallback then exprDeclParser else MP.empty) case tokKind of TkKeywordData -> case nextTokKind of @@ -86,11 +95,7 @@ TkSpecialComma -> sigOrValueDecl TkReservedEquals -> valueDecl _ -> nonBareVarPatternBindDeclParser <|> valueDecl - _ -> - (if typeSigPrefix then typeSigOrPatternTypeSigDeclParser else MP.empty) - <|> MP.try valueDeclParser - <|> patternBindDeclParser - <|> (if exprFallback then exprDeclParser else MP.empty) + _ -> fallbackDecl -- | Like 'patternBindDeclParser' but rejects bare variable patterns. -- When the leading token is a variable identifier, a bare @x = 5@ must be @@ -607,10 +612,10 @@ symbolicOperatorParser = tokenSatisfy "fixity operator" $ \tok -> case lexTokenKind tok of - TkVarSym op -> Just (mkUnqualifiedName NameVarSym op) - TkConSym op -> Just (mkUnqualifiedName NameConSym op) - TkReservedColon -> Just (mkUnqualifiedName NameConSym ":") - TkReservedRightArrow -> Just (mkUnqualifiedName NameVarSym "->") + TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op) + TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op) + TkReservedColon -> Just (mkUnqualifiedNameAt tok NameConSym ":") + TkReservedRightArrow -> Just (mkUnqualifiedNameAt tok NameVarSym "->") _ -> Nothing backtickIdentifierParser = do expectedTok TkSpecialBacktick @@ -1232,15 +1237,22 @@ pure (PrefixBinderHead name (params <> tailParams)) typeDeclHeadParser :: TokParser (BinderHead UnqualifiedName) -typeDeclHeadParser = declHeadParserWith (unqualifiedNameFromText <$> typeSynonymOperatorParser) +typeDeclHeadParser = declHeadParserWith typeSynonymOperatorParser -typeSynonymOperatorParser :: TokParser Text +typeSynonymOperatorParser :: TokParser UnqualifiedName typeSynonymOperatorParser = - operatorTextParser <|> backtickTypeSynonymIdentifierParser + symbolicTypeSynonymOperatorParser <|> backtickTypeSynonymIdentifierParser where + symbolicTypeSynonymOperatorParser = + tokenSatisfy "type synonym operator" $ \tok -> + case lexTokenKind tok of + TkVarSym op -> Just (mkUnqualifiedNameAt tok NameVarSym op) + TkConSym op -> Just (mkUnqualifiedNameAt tok NameConSym op) + TkReservedAt -> Just (mkUnqualifiedNameAt tok NameVarSym "@") + _ -> Nothing backtickTypeSynonymIdentifierParser = do expectedTok TkSpecialBacktick - op <- identifierTextParser + op <- identifierUnqualifiedNameParser expectedTok TkSpecialBacktick pure op @@ -1284,9 +1296,6 @@ classHeadParser :: TokParser (BinderHead UnqualifiedName) classHeadParser = declHeadParserWith (nameToUnqualified <$> typeFamilyOperatorParser) -nameToUnqualified :: Name -> UnqualifiedName -nameToUnqualified name = mkUnqualifiedName (nameType name) (nameText name) - binderHeadToTypeFamilyHead :: SourceSpan -> BinderHead UnqualifiedName -> (TypeHeadForm, Type, [TyVarBinder]) binderHeadToTypeFamilyHead span' binderHead = case binderHead of @@ -1523,12 +1532,14 @@ symbolicConstructorOperatorParser <|> backtickConstructorIdentifierParser where symbolicConstructorOperatorParser = - tokenSatisfy "constructor operator" $ \tok -> - case lexTokenKind tok of - TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op)) - TkQConSym modName op -> Just (mkName (Just modName) NameConSym op) - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) - _ -> Nothing + (qualifyName Nothing <$> constructorOperatorUnqualifiedNameParser) + <|> tokenSatisfy + "qualified constructor operator" + ( \tok -> + case lexTokenKind tok of + TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op) + _ -> Nothing + ) backtickConstructorIdentifierParser = do expectedTok TkSpecialBacktick op <- constructorNameParser @@ -1570,7 +1581,7 @@ constructorUnqualifiedNameParser <|> do op <- parens constructorOperatorParser - pure (mkUnqualifiedName (nameType op) (nameText op)) + pure (nameToUnqualified op) -- | Parse a pattern synonym declaration. -- Handles prefix, infix, and record forms with all three directionalities. @@ -1600,7 +1611,7 @@ lhs <- lowerIdentifierParser op <- constructorOperatorParser rhs <- lowerIdentifierParser - pure (mkUnqualifiedName (nameType op) (nameText op), PatSynInfixArgs lhs rhs) + pure (nameToUnqualified op, PatSynInfixArgs lhs rhs) -- | Parse a record or prefix pattern synonym LHS. -- Record: @Con {field1, field2, ...}@ diff --git a/src/Aihc/Parser/Internal/Expr.hs b/src/Aihc/Parser/Internal/Expr.hs --- a/src/Aihc/Parser/Internal/Expr.hs +++ b/src/Aihc/Parser/Internal/Expr.hs @@ -21,7 +21,7 @@ import Aihc.Parser.Internal.Type (typeAtomParser, typeParser, typeSignatureParser) import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax -import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken) +import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken) import Control.Monad (guard) import Data.Functor (($>)) import Data.Text (Text) @@ -360,7 +360,8 @@ tokenExprParser :: String -> (LexToken -> Maybe Expr) -> TokParser Expr tokenExprParser expected matchToken = - withSpanAnn (EAnn . mkAnnotation) (tokenSatisfy expected matchToken) + tokenSatisfy expected $ \tok -> + EAnn (mkAnnotation (lexTokenSpan tok)) <$> matchToken tok charExprParser :: TokParser Expr charExprParser = @@ -394,11 +395,18 @@ -- | Shared application parser used by the report core and contextual -- variants. The caller chooses the @aexp@-like atom parser. appExprParserWith :: TokParser Expr -> TokParser Expr -appExprParserWith atomParser = withSpanAnn (EAnn . mkAnnotation) $ do +appExprParserWith atomParser = do + startInput <- MP.getInput first <- atomParser rest <- MP.many appArg - pure $ - foldl applyArg first rest + case rest of + [] -> pure first + _ -> do + endInput <- MP.getInput + let startSpan = inputStartSpan startInput + endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput) + appSpan = mergeSourceSpans startSpan endSpan + pure (EAnn (mkAnnotation appSpan) (foldl applyArg first rest)) where appArg :: TokParser (Either Type Expr) appArg = (Left <$> typeAppArg) <|> (Right <$> appExprArgParser) @@ -516,27 +524,10 @@ -- > | aexp '{' fbind_1 ',' ... ',' fbind_n '}' recordBaseAtomExprParserWith :: AtomContext -> TokParser Expr recordBaseAtomExprParserWith atomContext = do - thAny <- thAnyEnabled tok <- lookAhead anySingle case lexTokenKind tok of TkImplicitParam {} -> implicitParamExprParser - _ -> - MP.try (prefixNegateAtomExprParserWith atomContext) - <|> MP.try parenOperatorExprParser - <|> (if thAny then thQuoteExprParser else MP.empty) - <|> (if thAny then thNameQuoteExprParser else MP.empty) - <|> (if thAny then thTypedSpliceParser else MP.empty) - <|> (if thAny then thUntypedSpliceParser else MP.empty) - <|> quasiQuoteExprParser - <|> parenExprParser - <|> listExprParser - <|> intExprParser - <|> floatExprParser - <|> charExprParser - <|> stringExprParser - <|> overloadedLabelExprParser - <|> wildcardExprParser - <|> varExprParser + _ -> simpleAtomExprParserWith atomContext -- | Parse an atom without record construction/update syntax. -- @@ -549,42 +540,69 @@ atomExprParserWith :: AtomContext -> TokParser Expr atomExprParserWith atomContext = do - blockArgsEnabled <- isExtensionEnabled BlockArguments - thAny <- thAnyEnabled - explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces - requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments tok <- lookAhead anySingle case lexTokenKind tok of TkImplicitParam {} -> implicitParamExprParser - TkKeywordType - | explicitNamespacesEnabled || requiredTypeArgumentsEnabled -> explicitTypeExprParser + TkKeywordType -> do + explicitNamespacesEnabled <- isExtensionEnabled ExplicitNamespaces + requiredTypeArgumentsEnabled <- isExtensionEnabled RequiredTypeArguments + if explicitNamespacesEnabled || requiredTypeArgumentsEnabled + then explicitTypeExprParser + else simpleAtomExprParserWith atomContext TkReservedBackslash -> lambdaExprParser - TkKeywordLet -> letExprParser - TkKeywordDo | blockArgsEnabled -> doExprParser - TkKeywordMdo | blockArgsEnabled -> mdoExprParser - TkQualifiedDo {} | blockArgsEnabled -> qualifiedDoExprParser - TkQualifiedMdo {} | blockArgsEnabled -> qualifiedMdoExprParser - TkKeywordCase | blockArgsEnabled -> caseExprParser - TkKeywordIf | blockArgsEnabled -> ifExprParser - TkKeywordProc | blockArgsEnabled && atomContext == NormalExprAtom -> procExprParser - _ -> - MP.try (prefixNegateAtomExprParserWith atomContext) - <|> MP.try parenOperatorExprParser - <|> (if thAny then thQuoteExprParser else MP.empty) - <|> (if thAny then thNameQuoteExprParser else MP.empty) - <|> (if thAny then thTypedSpliceParser else MP.empty) - <|> (if thAny then thUntypedSpliceParser else MP.empty) - <|> quasiQuoteExprParser - <|> parenExprParser - <|> listExprParser - <|> intExprParser - <|> floatExprParser - <|> charExprParser - <|> stringExprParser - <|> overloadedLabelExprParser - <|> wildcardExprParser - <|> varExprParser + TkKeywordLet -> blockAtom letExprParser + TkKeywordDo -> blockAtom doExprParser + TkKeywordMdo -> blockAtom mdoExprParser + TkQualifiedDo {} -> blockAtom qualifiedDoExprParser + TkQualifiedMdo {} -> blockAtom qualifiedMdoExprParser + TkKeywordCase -> blockAtom caseExprParser + TkKeywordIf -> blockAtom ifExprParser + TkKeywordProc + | atomContext == NormalExprAtom -> blockAtom procExprParser + _ -> simpleAtomExprParserWith atomContext + where + blockAtom parser = do + blockArgsEnabled <- isExtensionEnabled BlockArguments + if blockArgsEnabled + then parser + else simpleAtomExprParserWith atomContext +simpleAtomExprParserWith :: AtomContext -> TokParser Expr +simpleAtomExprParserWith atomContext = do + tok <- lookAhead anySingle + case lexTokenKind tok of + TkPrefixMinus -> prefixNegateAtomExprParserWith atomContext + TkSpecialLParen -> MP.try parenOperatorExprParser <|> parenExprParser + TkSpecialUnboxedLParen -> parenExprParser + TkSpecialLBracket -> listExprParser + TkInteger {} -> intExprParser + TkFloat {} -> floatExprParser + TkChar {} -> charExprParser + TkCharHash {} -> charExprParser + TkString {} -> stringExprParser + TkStringHash {} -> stringExprParser + TkOverloadedLabel {} -> overloadedLabelExprParser + TkKeywordUnderscore -> wildcardExprParser + TkVarId {} -> varExprParser + TkConId {} -> varExprParser + TkQVarId {} -> varExprParser + TkQConId {} -> varExprParser + TkQuasiQuote {} -> quasiQuoteExprParser + TkTHExpQuoteOpen -> thAtom thQuoteExprParser + TkTHTypedQuoteOpen -> thAtom thQuoteExprParser + TkTHDeclQuoteOpen -> thAtom thQuoteExprParser + TkTHTypeQuoteOpen -> thAtom thQuoteExprParser + TkTHPatQuoteOpen -> thAtom thQuoteExprParser + TkTHQuoteTick -> thAtom thNameQuoteExprParser + TkTHTypeQuoteTick -> thAtom thNameQuoteExprParser + TkTHTypedSplice -> thAtom thTypedSpliceParser + TkTHSplice -> thAtom thUntypedSpliceParser + _ -> varExprParser + where + thAtom parser = do + thAny <- thAnyEnabled + if thAny then parser else varExprParser + explicitTypeExprParser :: TokParser Expr explicitTypeExprParser = withSpanAnn (EAnn . mkAnnotation) $ do expectedTok TkKeywordType @@ -633,20 +651,20 @@ operatorExprNameParser = tokenSatisfy "operator" $ \tok -> case lexTokenKind tok of - TkVarSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym)) - TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym)) - TkQVarSym modName sym -> Just (mkName (Just modName) NameVarSym sym) - TkQConSym modName sym -> Just (mkName (Just modName) NameConSym sym) - TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "@")) - TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "-")) - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) - TkReservedDoubleColon -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "::")) - TkReservedEquals -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "=")) - TkReservedPipe -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "|")) - TkReservedLeftArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "<-")) - TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "->")) - TkReservedDoubleArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "=>")) - TkReservedDotDot -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "..")) + TkVarSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym)) + TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym)) + TkQVarSym modName sym -> Just (mkNameAt tok (Just modName) NameVarSym sym) + TkQConSym modName sym -> Just (mkNameAt tok (Just modName) NameConSym sym) + TkReservedAt -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "@")) + TkMinusOperator -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "-")) + TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":")) + TkReservedDoubleColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "::")) + TkReservedEquals -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "=")) + TkReservedPipe -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "|")) + TkReservedLeftArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "<-")) + TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "->")) + TkReservedDoubleArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "=>")) + TkReservedDotDot -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "..")) _ -> Nothing rhsParser :: TokParser (Rhs Expr) @@ -1297,17 +1315,31 @@ ) varExprParser :: TokParser Expr -varExprParser = withSpanAnn (EAnn . mkAnnotation) $ do - EVar <$> identifierNameParser +varExprParser = do + (tok, name) <- identifierNameWithTokenParser + pure (EAnn (mkAnnotation (lexTokenSpan tok)) (EVar name)) implicitParamExprParser :: TokParser Expr -implicitParamExprParser = withSpanAnn (EAnn . mkAnnotation) $ do - EVar . qualifyName Nothing . mkUnqualifiedName NameVarId <$> implicitParamNameParser +implicitParamExprParser = + tokenSatisfy "implicit parameter" $ \tok -> + case lexTokenKind tok of + TkImplicitParam name -> + Just $ + EAnn + (mkAnnotation (lexTokenSpan tok)) + (EVar (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name))) + _ -> Nothing wildcardExprParser :: TokParser Expr -wildcardExprParser = withSpanAnn (EAnn . mkAnnotation) $ do - expectedTok TkKeywordUnderscore - pure (EVar (qualifyName Nothing (mkUnqualifiedName NameVarId "_"))) +wildcardExprParser = + tokenSatisfy "wildcard" $ \tok -> + case lexTokenKind tok of + TkKeywordUnderscore -> + Just $ + EAnn + (mkAnnotation (lexTokenSpan tok)) + (EVar (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId "_"))) + _ -> Nothing -- | Parse Template Haskell quote brackets thQuoteExprParser :: TokParser Expr diff --git a/src/Aihc/Parser/Internal/Pattern.hs b/src/Aihc/Parser/Internal/Pattern.hs --- a/src/Aihc/Parser/Internal/Pattern.hs +++ b/src/Aihc/Parser/Internal/Pattern.hs @@ -15,9 +15,9 @@ import Aihc.Parser.Internal.Common import {-# SOURCE #-} Aihc.Parser.Internal.Expr (atomExprParser, exprParser) import Aihc.Parser.Internal.Type (typeParser) -import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenText) +import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax -import Aihc.Parser.Types (ParserErrorComponent (..), mkFoundToken) +import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken) import Text.Megaparsec (anySingle, lookAhead, (<|>)) import Text.Megaparsec qualified as MP @@ -71,9 +71,9 @@ symbolicConOp = tokenSatisfy "constructor operator" $ \tok -> case lexTokenKind tok of - TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op)) - TkQConSym modName op -> Just (mkName (Just modName) NameConSym op) - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) + TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op)) + TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op) + TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":")) _ -> Nothing backtickConOp = MP.try $ @@ -185,61 +185,83 @@ numericLiteralParser = intLiteralParser <|> floatLiteralParser wildcardPatternParser :: TokParser Pattern -wildcardPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do - expectedTok TkKeywordUnderscore - pure PWildcard +wildcardPatternParser = + tokenSatisfy "wildcard" $ \tok -> + case lexTokenKind tok of + TkKeywordUnderscore -> Just (PAnn (mkAnnotation (lexTokenSpan tok)) PWildcard) + _ -> Nothing literalPatternParser :: TokParser Pattern -literalPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do - PLit <$> literalParser +literalPatternParser = + tokenSatisfy "literal" $ \tok -> do + lit <- literalFromToken tok + let ann = mkAnnotation (lexTokenSpan tok) + pure (PAnn ann (PLit (LitAnn ann lit))) quasiQuotePatternParser :: TokParser Pattern -quasiQuotePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do - (quoter, body) <- tokenSatisfy "quasi quote" $ \tok -> +quasiQuotePatternParser = + tokenSatisfy "quasi quote" $ \tok -> case lexTokenKind tok of - TkQuasiQuote q b -> Just (q, b) + TkQuasiQuote quoter body -> Just (PAnn (mkAnnotation (lexTokenSpan tok)) (PQuasiQuote quoter body)) _ -> Nothing - pure (PQuasiQuote quoter body) literalParser :: TokParser Literal literalParser = intLiteralParser <|> floatLiteralParser <|> charLiteralParser <|> stringLiteralParser tokenLiteralParser :: String -> (LexToken -> Maybe Literal) -> TokParser Literal tokenLiteralParser expected matchToken = - withSpanAnn (LitAnn . mkAnnotation) (tokenSatisfy expected matchToken) + tokenSatisfy expected $ \tok -> + LitAnn (mkAnnotation (lexTokenSpan tok)) <$> matchToken tok +literalFromToken :: LexToken -> Maybe Literal +literalFromToken tok = + intLiteralFromToken tok + <|> floatLiteralFromToken tok + <|> charLiteralFromToken tok + <|> stringLiteralFromToken tok + intLiteralParser :: TokParser Literal intLiteralParser = - tokenLiteralParser "integer literal" $ \tok -> - case lexTokenKind tok of - TkInteger i nt -> Just (LitInt i nt (lexTokenText tok)) - _ -> Nothing + tokenLiteralParser "integer literal" intLiteralFromToken +intLiteralFromToken :: LexToken -> Maybe Literal +intLiteralFromToken tok = + case lexTokenKind tok of + TkInteger i nt -> Just (LitInt i nt (lexTokenText tok)) + _ -> Nothing + floatLiteralParser :: TokParser Literal floatLiteralParser = - tokenLiteralParser "floating literal" $ \tok -> - case lexTokenKind tok of - TkFloat x ft -> Just (LitFloat x ft (lexTokenText tok)) - _ -> Nothing + tokenLiteralParser "floating literal" floatLiteralFromToken +floatLiteralFromToken :: LexToken -> Maybe Literal +floatLiteralFromToken tok = + case lexTokenKind tok of + TkFloat x ft -> Just (LitFloat x ft (lexTokenText tok)) + _ -> Nothing + charLiteralParser :: TokParser Literal -charLiteralParser = withSpanAnn (LitAnn . mkAnnotation) $ do - (ctor, c, repr) <- tokenSatisfy "character literal" $ \tok -> - case lexTokenKind tok of - TkChar x -> Just (LitChar, x, lexTokenText tok) - TkCharHash x txt -> Just (LitCharHash, x, txt) - _ -> Nothing - pure (ctor c repr) +charLiteralParser = + tokenLiteralParser "character literal" charLiteralFromToken +charLiteralFromToken :: LexToken -> Maybe Literal +charLiteralFromToken tok = + case lexTokenKind tok of + TkChar x -> Just (LitChar x (lexTokenText tok)) + TkCharHash x txt -> Just (LitCharHash x txt) + _ -> Nothing + stringLiteralParser :: TokParser Literal -stringLiteralParser = withSpanAnn (LitAnn . mkAnnotation) $ do - (ctor, s, repr) <- tokenSatisfy "string literal" $ \tok -> - case lexTokenKind tok of - TkString x -> Just (LitString, x, lexTokenText tok) - TkStringHash x txt -> Just (LitStringHash, x, txt) - _ -> Nothing - pure (ctor s repr) +stringLiteralParser = + tokenLiteralParser "string literal" stringLiteralFromToken +stringLiteralFromToken :: LexToken -> Maybe Literal +stringLiteralFromToken tok = + case lexTokenKind tok of + TkString x -> Just (LitString x (lexTokenText tok)) + TkStringHash x txt -> Just (LitStringHash x txt) + _ -> Nothing + -- | Parse Template Haskell pattern splice: $pat or $(pat) thSplicePatternParser :: TokParser Pattern thSplicePatternParser = withSpanAnn (PAnn . mkAnnotation) $ do @@ -266,19 +288,24 @@ ) varOrConPatternParser :: TokParser Pattern -varOrConPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do - name <- identifierNameParser +varOrConPatternParser = do + (tok, name) <- identifierNameWithTokenParser mNextTok <- MP.optional (lookAhead anySingle) + let ann = mkAnnotation (lexTokenSpan tok) case mNextTok of Just nextTok | isConLikeName name && lexTokenKind nextTok == TkSpecialLBrace -> do (fields, hasWildcard) <- braces recordPatternFieldListParser - pure (PRecord name fields hasWildcard) + endInput <- MP.getInput + let endSpan = maybe noSourceSpan lexTokenSpan (tokStreamPrevToken endInput) + recordSpan = mergeSourceSpans (lexTokenSpan tok) endSpan + pure (PAnn (mkAnnotation recordSpan) (PRecord name fields hasWildcard)) _ -> pure $ - if isConLikeName name - then PCon name [] [] - else PVar (mkUnqualifiedName (nameType name) (nameText name)) + PAnn ann $ + if isConLikeName name + then PCon name [] [] + else PVar (nameToUnqualified name) recordFieldPatternParser :: TokParser (RecordField Pattern) recordFieldPatternParser = do @@ -290,7 +317,7 @@ pure (RecordField field pat False) Nothing -> do -- NamedFieldPuns: just "field" means "field = field" - pure (RecordField field (PVar (mkUnqualifiedName (nameType field) (nameText field))) True) + pure (RecordField field (PVar (nameToUnqualified field)) True) -- | Parse the contents of record pattern braces, supporting RecordWildCards ".." recordPatternFieldListParser :: TokParser ([RecordField Pattern], Bool) @@ -443,14 +470,15 @@ -- Parse an operator token as a variable or constructor pattern. operatorPatternParser :: TokParser Pattern - operatorPatternParser = withSpanAnn (PAnn . mkAnnotation) $ do + operatorPatternParser = do tok' <- anySingle + let ann = mkAnnotation (lexTokenSpan tok') case lexTokenKind tok' of - TkVarSym op -> pure (PVar (mkUnqualifiedName NameVarSym op)) - TkConSym op -> pure (PCon (qualifyName Nothing (mkUnqualifiedName NameConSym op)) [] []) - TkQConSym modName op -> pure (PCon (mkName (Just modName) NameConSym op) [] []) - TkReservedColon -> pure (PCon (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) [] []) - TkReservedAt -> pure (PVar (mkUnqualifiedName NameVarSym "@")) + TkVarSym op -> pure (PAnn ann (PVar (mkUnqualifiedNameAt tok' NameVarSym op))) + TkConSym op -> pure (PAnn ann (PCon (qualifyName Nothing (mkUnqualifiedNameAt tok' NameConSym op)) [] [])) + TkQConSym modName op -> pure (PAnn ann (PCon (mkNameAt tok' (Just modName) NameConSym op) [] [])) + TkReservedColon -> pure (PAnn ann (PCon (qualifyName Nothing (mkUnqualifiedNameAt tok' NameConSym ":")) [] [])) + TkReservedAt -> pure (PAnn ann (PVar (mkUnqualifiedNameAt tok' NameVarSym "@"))) _ -> MP.customFailure UnexpectedTokenExpecting diff --git a/src/Aihc/Parser/Internal/Testing.hs b/src/Aihc/Parser/Internal/Testing.hs new file mode 100644 --- /dev/null +++ b/src/Aihc/Parser/Internal/Testing.hs @@ -0,0 +1,22 @@ +-- | Internal parser entry points used by generative tests. +-- +-- This module is exposed so the test-only @fuzz@ component can exercise the +-- token parsers compiled into the main library. It is not a stable public API. +module Aihc.Parser.Internal.Testing + ( LexToken (..), + LexTokenKind (..), + TokenOrigin (..), + lexModuleTokens, + lexTokens, + parseDeclFromTokens, + parseExprFromTokens, + parseImportDeclFromTokens, + parseModuleFromTokens, + parseModuleHeaderFromTokens, + parsePatternFromTokens, + parseTypeFromTokens, + ) +where + +import Aihc.Parser.Internal.FromTokens +import Aihc.Parser.Lex diff --git a/src/Aihc/Parser/Internal/Type.hs b/src/Aihc/Parser/Internal/Type.hs --- a/src/Aihc/Parser/Internal/Type.hs +++ b/src/Aihc/Parser/Internal/Type.hs @@ -261,15 +261,15 @@ unpromotedInfixOperatorParser = tokenSatisfy "type infix operator" $ \tok -> case lexTokenKind tok of - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Unpromoted) + TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"), Unpromoted) TkVarSym op | op /= "." && op /= "!" && op /= "'" -> - Just (qualifyName Nothing (mkUnqualifiedName NameVarSym op), Unpromoted) - TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym op), Unpromoted) - TkQVarSym modName op -> Just (mkName (Just modName) NameVarSym op, Unpromoted) - TkQConSym modName op -> Just (mkName (Just modName) NameConSym op, Unpromoted) + Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym op), Unpromoted) + TkConSym op -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym op), Unpromoted) + TkQVarSym modName op -> Just (mkNameAt tok (Just modName) NameVarSym op, Unpromoted) + TkQConSym modName op -> Just (mkNameAt tok (Just modName) NameConSym op, Unpromoted) _ -> Nothing backtickTypeOperatorParser = MP.try $ do @@ -281,10 +281,10 @@ typeOperatorIdentifierParser = tokenSatisfy "type operator identifier" $ \tok -> case lexTokenKind tok of - TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedName NameVarId name)) - TkConId name -> Just (qualifyName Nothing (mkUnqualifiedName NameConId name)) - TkQVarId modName name -> Just (mkName (Just modName) NameVarId name) - TkQConId modName name -> Just (mkName (Just modName) NameConId name) + TkVarId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarId name)) + TkConId name -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConId name)) + TkQVarId modName name -> Just (mkNameAt tok (Just modName) NameVarId name) + TkQConId modName name -> Just (mkNameAt tok (Just modName) NameConId name) _ -> Nothing promotedInfixOperatorParser = MP.try $ do @@ -294,13 +294,13 @@ -- or ':$$: for a promoted user-defined type operator) tokenSatisfy "promoted type infix operator" $ \tok -> case lexTokenKind tok of - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":"), Promoted) + TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":"), Promoted) TkVarSym sym | sym /= "." && sym /= "!" -> - Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym), Promoted) - TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym), Promoted) - TkQVarSym modQual sym -> Just (mkName (Just modQual) NameVarSym sym, Promoted) - TkQConSym modQual sym -> Just (mkName (Just modQual) NameConSym sym, Promoted) + Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym), Promoted) + TkConSym sym -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym), Promoted) + TkQVarSym modQual sym -> Just (mkNameAt tok (Just modQual) NameVarSym sym, Promoted) + TkQConSym modQual sym -> Just (mkNameAt tok (Just modQual) NameConSym sym, Promoted) _ -> Nothing -- | Report core: @@ -368,25 +368,40 @@ -- This parser also admits extension atoms such as promoted types, -- quasi-quotes, splices, wildcards, and implicit-parameter types. typeAtomParser :: TokParser Type -typeAtomParser = do - thAny <- thAnyEnabled - ipEnabled <- isExtensionEnabled ImplicitParams - MP.try promotedTypeParser - <|> typeLiteralTypeParser - <|> typeQuasiQuoteParser - <|> (if thAny then thSpliceTypeParser else MP.empty) - <|> (if ipEnabled then typeImplicitParamParser else MP.empty) - <|> typeListParser - <|> MP.try typeParenOperatorParser - <|> typeParenOrTupleParser - <|> typeStarParser - <|> typeWildcardParser - <|> typeIdentifierParser +typeAtomParser = typeAtomParserByToken typeSignatureAtomParser :: TokParser Type -typeSignatureAtomParser = do - thAny <- thAnyEnabled - ipEnabled <- isExtensionEnabled ImplicitParams +typeSignatureAtomParser = typeAtomParserByToken + +typeAtomParserByToken :: TokParser Type +typeAtomParserByToken = do + tok <- MP.lookAhead MP.anySingle + case lexTokenKind tok of + TkInteger {} -> typeLiteralTypeParser + TkString {} -> typeLiteralTypeParser + TkChar {} -> typeLiteralTypeParser + TkQuasiQuote {} -> typeQuasiQuoteParser + TkTHSplice -> do + thAny <- thAnyEnabled + if thAny then thSpliceTypeParser else typeAtomParserAlternatives False False + TkImplicitParam {} -> do + ipEnabled <- isExtensionEnabled ImplicitParams + if ipEnabled then typeImplicitParamParser else typeAtomParserAlternatives False False + TkSpecialLBracket -> typeListParser + TkSpecialLParen -> MP.try typeParenOperatorParser <|> typeParenOrTupleParser + TkSpecialUnboxedLParen -> typeParenOrTupleParser + TkKeywordUnderscore -> typeWildcardParser + TkVarId {} -> typeIdentifierParser + TkConId {} -> typeIdentifierParser + TkQVarId {} -> typeIdentifierParser + TkQConId {} -> typeIdentifierParser + _ -> do + thAny <- thAnyEnabled + ipEnabled <- isExtensionEnabled ImplicitParams + typeAtomParserAlternatives thAny ipEnabled + +typeAtomParserAlternatives :: Bool -> Bool -> TokParser Type +typeAtomParserAlternatives thAny ipEnabled = MP.try promotedTypeParser <|> typeLiteralTypeParser <|> typeQuasiQuoteParser @@ -412,19 +427,20 @@ TImplicitParam name <$> typeSignatureParser typeWildcardParser :: TokParser Type -typeWildcardParser = withSpanAnn (TAnn . mkAnnotation) $ do - expectedTok TkKeywordUnderscore - pure TWildcard +typeWildcardParser = + tokenSatisfy "wildcard" $ \tok -> + case lexTokenKind tok of + TkKeywordUnderscore -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) TWildcard) + _ -> Nothing typeLiteralTypeParser :: TokParser Type -typeLiteralTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do - lit <- tokenSatisfy "type literal" $ \tok -> +typeLiteralTypeParser = + tokenSatisfy "type literal" $ \tok -> case lexTokenKind tok of - TkInteger n _ -> Just (TypeLitInteger n (lexTokenText tok)) - TkString s -> Just (TypeLitSymbol s (lexTokenText tok)) - TkChar c -> Just (TypeLitChar c (lexTokenText tok)) + TkInteger n _ -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TTypeLit (TypeLitInteger n (lexTokenText tok)))) + TkString s -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TTypeLit (TypeLitSymbol s (lexTokenText tok)))) + TkChar c -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TTypeLit (TypeLitChar c (lexTokenText tok)))) _ -> Nothing - pure (TTypeLit lit) promotedTypeParser :: TokParser Type promotedTypeParser = withSpanAnn (TAnn . mkAnnotation) $ do @@ -441,13 +457,13 @@ unicodeSyntax <- isExtensionEnabled UnicodeSyntax op <- tokenSatisfy "type operator" $ \tok -> case lexTokenKind tok of - TkVarSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym sym)) - TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym sym)) - TkQVarSym modQual sym -> Just (mkName (Just modQual) NameVarSym sym) - TkQConSym modQual sym -> Just (mkName (Just modQual) NameConSym sym) + TkVarSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym sym)) + TkConSym sym | not (isStarTypeSymbol starIsType unicodeSyntax sym) -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym sym)) + TkQVarSym modQual sym -> Just (mkNameAt tok (Just modQual) NameVarSym sym) + TkQConSym modQual sym -> Just (mkNameAt tok (Just modQual) NameConSym sym) -- Handle reserved operators that can be used as type constructors - TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedName NameVarSym "->")) - TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedName NameConSym ":")) + TkReservedRightArrow -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameVarSym "->")) + TkReservedColon -> Just (qualifyName Nothing (mkUnqualifiedNameAt tok NameConSym ":")) -- Note: ~ is now lexed as TkVarSym "~" so TkVarSym case handles it _ -> Nothing expectedTok TkSpecialRParen @@ -465,27 +481,26 @@ _ -> Nothing typeIdentifierParser :: TokParser Type -typeIdentifierParser = withSpanAnn (TAnn . mkAnnotation) $ do - name <- identifierNameParser +typeIdentifierParser = do + (tok, name) <- identifierNameWithTokenParser pure $ - case (nameQualifier name, nameType name, T.uncons (nameText name)) of - (Nothing, NameVarId, Just (c, _)) - | isLower c || c == '_' -> - TVar (mkUnqualifiedName NameVarId (nameText name)) - _ -> TCon name Unpromoted + TAnn (mkAnnotation (lexTokenSpan tok)) $ + case (nameQualifier name, nameType name, T.uncons (nameText name)) of + (Nothing, NameVarId, Just (c, _)) + | isLower c || c == '_' -> + TVar (nameToUnqualified name) + _ -> TCon name Unpromoted typeStarParser :: TokParser Type -typeStarParser = withSpanAnn (TAnn . mkAnnotation) $ do +typeStarParser = do starIsType <- isExtensionEnabled StarIsType unicodeSyntax <- isExtensionEnabled UnicodeSyntax if starIsType - then do - spelling <- tokenSatisfy "star kind" $ \tok -> - case lexTokenKind tok of - TkVarSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (lexTokenText tok) - TkConSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (lexTokenText tok) - _ -> Nothing - pure (TStar spelling) + then tokenSatisfy "star kind" $ \tok -> + case lexTokenKind tok of + TkVarSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TStar (lexTokenText tok))) + TkConSym sym | isStarTypeSymbol starIsType unicodeSyntax sym -> Just (TAnn (mkAnnotation (lexTokenSpan tok)) (TStar (lexTokenText tok))) + _ -> Nothing else MP.empty isStarTypeSymbol :: Bool -> Bool -> T.Text -> Bool diff --git a/src/Aihc/Parser/Lex.hs b/src/Aihc/Parser/Lex.hs --- a/src/Aihc/Parser/Lex.hs +++ b/src/Aihc/Parser/Lex.hs @@ -71,10 +71,8 @@ import Aihc.Parser.Lex.Types import Aihc.Parser.Syntax import Control.Applicative ((<|>)) -import Data.Char (GeneralCategory (..), generalCategory, isAscii, isAsciiLower, isAsciiUpper, isDigit) +import Data.Char (GeneralCategory (..), generalCategory, isAscii, isAsciiLower, isAsciiUpper, isDigit, ord) import Data.Maybe (fromMaybe, isJust) -import Data.Set (Set) -import Data.Set qualified as Set import Data.Text (Text, pattern Empty, pattern (:<)) import Data.Text qualified as T @@ -735,27 +733,31 @@ lexSymbol :: LexerEnv -> LexerState -> Maybe (LexToken, LexerState) lexSymbol env st = - firstTextKind st symbols + case lexerInput st of + '(' :< ('#' :< _) + | hasUnboxed -> Just (emitToken st "(#" TkSpecialUnboxedLParen) + '#' :< (')' :< _) + | hasUnboxed -> Just (emitToken st "#)" TkSpecialUnboxedRParen) + '(' :< ('|' :< rest) + | hasArrows, + bananaOpenAllowed rest -> + Just (emitToken st "(|" TkBananaOpen) + '(' :< _ -> Just (emitToken st "(" TkSpecialLParen) + ')' :< _ -> Just (emitToken st ")" TkSpecialRParen) + '[' :< _ -> Just (emitToken st "[" TkSpecialLBracket) + ']' :< _ -> Just (emitToken st "]" TkSpecialRBracket) + '{' :< _ -> Just (emitToken st "{" TkSpecialLBrace) + '}' :< _ -> Just (emitToken st "}" TkSpecialRBrace) + ',' :< _ -> Just (emitToken st "," TkSpecialComma) + ';' :< _ -> Just (emitToken st ";" TkSpecialSemicolon) + '`' :< _ -> Just (emitToken st "`" TkSpecialBacktick) + _ -> Nothing where - symbols = - ( if hasExt UnboxedTuples env || hasExt UnboxedSums env - then [("(#", TkSpecialUnboxedLParen), ("#)", TkSpecialUnboxedRParen)] - else [] - ) - <> [("(|", TkBananaOpen) | hasExt Arrows env, bananaOpenAllowed] - <> [ ("(", TkSpecialLParen), - (")", TkSpecialRParen), - ("[", TkSpecialLBracket), - ("]", TkSpecialRBracket), - ("{", TkSpecialLBrace), - ("}", TkSpecialRBrace), - (",", TkSpecialComma), - (";", TkSpecialSemicolon), - ("`", TkSpecialBacktick) - ] + hasUnboxed = hasExt UnboxedTuples env || hasExt UnboxedSums env + hasArrows = hasExt Arrows env - bananaOpenAllowed = - case T.drop 2 (lexerInput st) of + bananaOpenAllowed rest = + case rest of c :< _ -> not (isSymbolicOpChar c) _ -> True @@ -818,8 +820,7 @@ Right (body, _) -> let raw = "\"\"\"" <> body <> "\"\"\"" decoded = T.pack (processMultilineString (T.unpack body)) - (tokTxt, tokKind, st') = - withOptionalMagicHashSuffix 1 env st raw (TkString decoded) (TkStringHash decoded) + (tokTxt, tokKind, st') = lexStringKind env st raw decoded in Just (mkToken st st' tokTxt tokKind, st') Left raw -> let full = "\"\"\"" <> raw @@ -832,8 +833,7 @@ Right (body, _) -> let rawT = "\"" <> body <> "\"" decoded = fromMaybe body (decodeStringBody body) - (tokTxt, tokKind, st') = - withOptionalMagicHashSuffix 1 env st rawT (TkString decoded) (TkStringHash decoded) + (tokTxt, tokKind, st') = lexStringKind env st rawT decoded in Just (mkToken st st' tokTxt tokKind, st') Left raw -> let full = "\"" <> raw @@ -841,6 +841,14 @@ in Just (mkErrorToken st st' full "unterminated string literal", st') _ -> Nothing +lexStringKind :: LexerEnv -> LexerState -> Text -> Text -> (Text, LexTokenKind, LexerState) +lexStringKind env st raw decoded = + case withOptionalMagicHashSuffix 1 env st raw (TkString decoded) (TkStringHash decoded) of + (tokTxt, TkStringHash _ _, st') + | T.any ((>= 256) . ord) decoded -> + (tokTxt, TkError "primitive string literal contains a character outside Latin-1", st') + result -> result + lexQuasiQuote :: LexerState -> Maybe (LexToken, LexerState) lexQuasiQuote st = case lexerInput st of @@ -1024,7 +1032,7 @@ c :< _ -> isSymbolicOpChar c _ -> False -keywordTokenKind :: Set Extension -> Text -> Maybe LexTokenKind +keywordTokenKind :: ExtensionSet -> Text -> Maybe LexTokenKind keywordTokenKind exts txt = case txt of "case" -> Just TkKeywordCase @@ -1051,12 +1059,12 @@ "type" -> Just TkKeywordType "where" -> Just TkKeywordWhere "_" -> Just TkKeywordUnderscore - "proc" | Set.member Arrows exts -> Just TkKeywordProc - "rec" | Set.member Arrows exts || Set.member RecursiveDo exts -> Just TkKeywordRec - "mdo" | Set.member RecursiveDo exts -> Just TkKeywordMdo - "pattern" | Set.member PatternSynonyms exts -> Just TkKeywordPattern - "by" | Set.member TransformListComp exts -> Just TkKeywordBy - "using" | Set.member TransformListComp exts -> Just TkKeywordUsing + "proc" | memberExtension Arrows exts -> Just TkKeywordProc + "rec" | memberExtension Arrows exts || memberExtension RecursiveDo exts -> Just TkKeywordRec + "mdo" | memberExtension RecursiveDo exts -> Just TkKeywordMdo + "pattern" | memberExtension PatternSynonyms exts -> Just TkKeywordPattern + "by" | memberExtension TransformListComp exts -> Just TkKeywordBy + "using" | memberExtension TransformListComp exts -> Just TkKeywordUsing _ -> Nothing reservedOpTokenKind :: Text -> Maybe LexTokenKind diff --git a/src/Aihc/Parser/Lex/Layout.hs b/src/Aihc/Parser/Lex/Layout.hs --- a/src/Aihc/Parser/Lex/Layout.hs +++ b/src/Aihc/Parser/Lex/Layout.hs @@ -451,6 +451,7 @@ layoutBuffer = [] } in (preInserted <> pendingInserted <> bolInserted <> [tok], stNext) +{-# INLINE layoutTransition #-} closeImplicitLayoutContext :: LayoutState -> Maybe LayoutState closeImplicitLayoutContext st = diff --git a/src/Aihc/Parser/Lex/Quoted.hs b/src/Aihc/Parser/Lex/Quoted.hs --- a/src/Aihc/Parser/Lex/Quoted.hs +++ b/src/Aihc/Parser/Lex/Quoted.hs @@ -74,12 +74,9 @@ -- We intentionally recognize string gaps here so a gap-closing backslash does -- not incorrectly escape the following quote. consumedEscapeTail :: Text -> Maybe Int -consumedEscapeTail rest = - if T.null rest - then Nothing - else do - (_, rest') <- parseEscape rest - pure (T.length rest - T.length rest') +consumedEscapeTail rest = do + (_, _, consumed) <- parseEscapeWithLength rest + pure consumed -- | Decode the body of a Haskell string literal (content between the quotes, -- without the surrounding @\"@ characters) natively on 'Text', avoiding the @@ -107,60 +104,66 @@ isOctDigit c = c >= '0' && c <= '7' parseEscape :: Text -> Maybe (Maybe Char, Text) -parseEscape t = case T.uncons t of +parseEscape = fmap (\(decoded, rest, _) -> (decoded, rest)) . parseEscapeWithLength + +parseEscapeWithLength :: Text -> Maybe (Maybe Char, Text, Int) +parseEscapeWithLength t = case T.uncons t of Nothing -> Nothing Just (c, rest) -> case c of - 'a' -> Just (Just '\a', rest) - 'b' -> Just (Just '\b', rest) - 'f' -> Just (Just '\f', rest) - 'n' -> Just (Just '\n', rest) - 'r' -> Just (Just '\r', rest) - 't' -> Just (Just '\t', rest) - 'v' -> Just (Just '\v', rest) - '\\' -> Just (Just '\\', rest) - '"' -> Just (Just '"', rest) - '\'' -> Just (Just '\'', rest) - '&' -> Just (Nothing, rest) -- empty escape + 'a' -> consumedOne (Just '\a') rest + 'b' -> consumedOne (Just '\b') rest + 'f' -> consumedOne (Just '\f') rest + 'n' -> consumedOne (Just '\n') rest + 'r' -> consumedOne (Just '\r') rest + 't' -> consumedOne (Just '\t') rest + 'v' -> consumedOne (Just '\v') rest + '\\' -> consumedOne (Just '\\') rest + '"' -> consumedOne (Just '"') rest + '\'' -> consumedOne (Just '\'') rest + '&' -> consumedOne Nothing rest -- empty escape '^' -> case T.uncons rest of -- control character \^X Just (cc, rest') | cc >= '@' && cc <= '_' -> - Just (Just (chr (ord cc - 64)), rest') + Just (Just (chr (ord cc - 64)), rest', 2) _ -> Nothing 'x' -> -- hex escape \xNN (use Integer to prevent Int overflow on long inputs) let (digits, rest') = T.span isHexDigit rest in if T.null digits then Nothing - else decodeNumericEscape 16 digits rest' + else decodeNumericEscape 16 1 digits rest' 'o' -> -- octal escape \oNN (use Integer to prevent Int overflow on long inputs) let (digits, rest') = T.span isOctDigit rest in if T.null digits then Nothing - else decodeNumericEscape 8 digits rest' + else decodeNumericEscape 8 1 digits rest' _ | isDigit c -> -- decimal escape \NNN (use Integer to prevent Int overflow on long inputs) let (moreDigits, rest') = T.span isDigit rest digits = T.cons c moreDigits - in decodeNumericEscape 10 digits rest' + in decodeNumericEscape 10 0 digits rest' | isSpace c -> -- gap escape \ whitespace \ - let rest' = T.dropWhile isSpace rest + let (spaces, rest') = T.span isSpace rest in case T.uncons rest' of - Just ('\\', rest'') -> Just (Nothing, rest'') + Just ('\\', rest'') -> Just (Nothing, rest'', 2 + T.length spaces) _ -> Nothing - | otherwise -> parseNamedEscape t + | otherwise -> parseNamedEscapeWithLength t where - decodeNumericEscape :: Integer -> Text -> Text -> Maybe (Maybe Char, Text) - decodeNumericEscape !base digits rest' = + consumedOne decoded rest' = Just (decoded, rest', 1) + + decodeNumericEscape :: Integer -> Int -> Text -> Text -> Maybe (Maybe Char, Text, Int) + decodeNumericEscape !base prefixLength digits rest' = let n = T.foldl' (\a d -> a * base + toInteger (digitToInt d)) (0 :: Integer) digits - in if n > 0x10FFFF then Nothing else Just (Just (chr (fromIntegral n)), rest') + consumed = prefixLength + T.length digits + in if n > 0x10FFFF then Nothing else Just (Just (chr (fromIntegral n)), rest', consumed) -parseNamedEscape :: Text -> Maybe (Maybe Char, Text) -parseNamedEscape t = foldr tryMatch Nothing namedEscapeTable +parseNamedEscapeWithLength :: Text -> Maybe (Maybe Char, Text, Int) +parseNamedEscapeWithLength t = foldr tryMatch Nothing namedEscapeTable where tryMatch (name, ch) fallback = case T.stripPrefix name t of - Just rest -> Just (Just ch, rest) + Just rest -> Just (Just ch, rest, T.length name) Nothing -> fallback -- Named ASCII escape sequences per the Haskell 2010 report. diff --git a/src/Aihc/Parser/Lex/Types.hs b/src/Aihc/Parser/Lex/Types.hs --- a/src/Aihc/Parser/Lex/Types.hs +++ b/src/Aihc/Parser/Lex/Types.hs @@ -51,8 +51,6 @@ import Control.DeepSeq (NFData) import Data.Char (GeneralCategory (..), generalCategory, isAscii, isSpace, ord) import Data.Data (Data) -import Data.Set (Set) -import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) @@ -215,12 +213,13 @@ deriving (Eq, Ord, Show, Generic, NFData) newtype LexerEnv = LexerEnv - { lexerExtensions :: Set Extension + { lexerExtensions :: ExtensionSet } deriving (Eq, Show) hasExt :: Extension -> LexerEnv -> Bool -hasExt ext env = Set.member ext (lexerExtensions env) +hasExt ext env = memberExtension ext (lexerExtensions env) +{-# INLINE hasExt #-} data LexerState = LexerState { lexerInput :: !Text, @@ -316,7 +315,7 @@ deriving (Eq, Show) mkLexerEnv :: [Extension] -> LexerEnv -mkLexerEnv exts = LexerEnv {lexerExtensions = Set.fromList exts} +mkLexerEnv exts = LexerEnv {lexerExtensions = mkExtensionSet exts} mkInitialLexerState :: FilePath -> [Extension] -> Text -> (LexerEnv, LexerState) mkInitialLexerState sourceName exts input = diff --git a/src/Aihc/Parser/Parens.hs b/src/Aihc/Parser/Parens.hs --- a/src/Aihc/Parser/Parens.hs +++ b/src/Aihc/Parser/Parens.hs @@ -1367,6 +1367,10 @@ needsCompTransformParens :: Expr -> Bool needsCompTransformParens = \case EAnn _ sub -> needsCompTransformParens sub + -- Transform-list contextual parsers terminate an if-expression before the + -- following @by@ or @using@ keyword. Parenthesizing it is not only + -- unnecessary: GHC preserves the grouping in its parsed fingerprint. + EIf {} -> False ETypeSig {} -> True EParen {} -> False EInfix _ _ rhs -> needsCompTransformInfixRhsParens rhs diff --git a/src/Aihc/Parser/Pretty.hs b/src/Aihc/Parser/Pretty.hs --- a/src/Aihc/Parser/Pretty.hs +++ b/src/Aihc/Parser/Pretty.hs @@ -44,7 +44,6 @@ hang, hardline, hsep, - indent, nest, nesting, parens, @@ -75,7 +74,7 @@ | otherwise = pretty raw prettySpliceBody :: Expr -> Doc ann -prettySpliceBody = nest 2 . prettyExpr +prettySpliceBody = prettyExpr -- | Pretty instance for Module - renders to valid Haskell source code. instance Pretty Module where @@ -297,7 +296,7 @@ RoleInfer -> "_" prettyValueDeclLines :: ValueDecl -> [Doc ann] -prettyValueDeclLines valueDecl = map (nest 2) $ +prettyValueDeclLines valueDecl = case valueDecl of PatternBind multTag pat rhs -> [prettyMultiplicityTag multTag <> prettyPattern pat <+> prettyRhs rhs] FunctionBind name matches -> @@ -319,14 +318,13 @@ -- | Pretty-print a pattern synonym declaration. prettyPatSynDecl :: PatSynDecl -> Doc ann prettyPatSynDecl ps = - hang 2 $ - hsep - ( ["pattern"] - <> prettyPatSynLhs (patSynDeclName ps) (patSynDeclArgs ps) - <> [dirArrow (patSynDeclDir ps)] - <> [prettyPattern (patSynDeclPat ps)] - <> prettyPatSynWhere (patSynDeclName ps) (patSynDeclDir ps) - ) + hsep + ( ["pattern"] + <> prettyPatSynLhs (patSynDeclName ps) (patSynDeclArgs ps) + <> [dirArrow (patSynDeclDir ps)] + <> [prettyPattern (patSynDeclPat ps)] + <> prettyPatSynWhere (patSynDeclName ps) (patSynDeclDir ps) + ) where dirArrow PatSynBidirectional = "=" dirArrow PatSynUnidirectional = "<-" @@ -347,19 +345,23 @@ prettyPatSynWhere _ PatSynUnidirectional = [] prettyPatSynWhere _ (PatSynExplicitBidirectional []) = ["where", spacedBraces mempty] prettyPatSynWhere name (PatSynExplicitBidirectional matches) = - ["where" <> hardline <> indent 2 (vsep (map (prettyFunctionMatch name) matches))] + ["where" <> nest 2 (hardline <> vsep (map (prettyFunctionMatch name) matches))] prettyFunctionMatchLines :: UnqualifiedName -> Match -> [Doc ann] prettyFunctionMatchLines name match = case matchRhs match of UnguardedRhs {} -> [prettyFunctionMatch name match] GuardedRhss _ grhss mWhereDecls -> - prettyFunctionHead name (matchHeadForm match) (matchPats match) - : map - (indent 2) - ( map prettyGuardedRhsBlock grhss - <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls] - ) + [ prettyFunctionHead name (matchHeadForm match) (matchPats match) + <> nest + 2 + ( hardline + <> vsep + ( map prettyGuardedRhsBlock grhss + <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls] + ) + ) + ] prettyFunctionMatch :: UnqualifiedName -> Match -> Doc ann prettyFunctionMatch name match = @@ -385,34 +387,27 @@ case rhs of UnguardedRhs _ body whereDecls -> "=" - <+> nest 4 (prettyExpr body) + <+> prettyExpr body <> prettyIndentedWhereClause whereDecls GuardedRhss _ guards whereDecls -> - hardline <> indent 2 (prettyGuardedRhssBlock guards whereDecls) + nest 2 (hardline <> prettyGuardedRhssBlock guards whereDecls) prettyWhereClauseBare :: Maybe [Decl] -> Doc ann prettyWhereClauseBare Nothing = mempty prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty prettyWhereClauseBare (Just decls) = - "where" <> hardline <> indent 2 (vsep (concatMap prettyDeclLines decls)) + "where" <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls)) prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann prettyIndentedWhereClause Nothing = mempty -prettyIndentedWhereClause whereDecls = hardline <> indent 2 (prettyWhereClauseBare whereDecls) +prettyIndentedWhereClause whereDecls = nest 2 (hardline <> prettyWhereClauseBare whereDecls) prettyTHDeclQuote :: [Decl] -> Doc ann -prettyTHDeclQuote [] = - hang 2 $ - "[d|" - <> hardline - <> "|]" +prettyTHDeclQuote [] = "[d| |]" prettyTHDeclQuote decls = - hang 2 $ - "[d|" - <> hardline - <> vsep (concatMap prettyDeclLines decls) - <> hardline - <> "|]" + "[d|" + <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls)) + <+> "|]" -- | Infix type-family heads use @l \`Op\` r@ with a 'NameConId' operator (e.g. -- @\`And\`@), so 'isSymbolicTypeName' is false; 'TypeHeadInfix' already marks @@ -555,7 +550,7 @@ PCon con typeArgs args -> hsep ([prettyPrefixName con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args) PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs PView viewExpr inner -> - prettyExpr viewExpr <> hardline <> indent 1 ("->" <+> prettyPattern inner) + prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyPattern inner) PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner PStrict inner -> "!" <> prettyPattern inner PIrrefutable inner -> "~" <> prettyPattern inner @@ -664,8 +659,7 @@ prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann prettyGadtConBlock ctors derivingClauses = "where" - <> hardline - <> indent 2 (vsep (map prettyDataCon ctors <> derivingParts derivingClauses)) + <> nest 2 (hardline <> vsep (map prettyDataCon ctors <> derivingParts derivingClauses)) derivingPart :: DerivingClause -> [Doc ann] derivingPart (DerivingClause strategy classes) = @@ -858,8 +852,7 @@ items -> headDoc <+> "where" - <> hardline - <> indent 2 (vsep (concatMap prettyClassItemLines items)) + <> nest 2 (hardline <> vsep (concatMap prettyClassItemLines items)) prettyClassFundeps :: [FunctionalDependency] -> [Doc ann] prettyClassFundeps deps = @@ -931,8 +924,7 @@ items -> headDoc <+> "where" - <> hardline - <> indent 2 (vsep (concatMap prettyInstanceItemLines items)) + <> nest 2 (hardline <> vsep (concatMap prettyInstanceItemLines items)) prettyStandaloneDeriving :: StandaloneDerivingDecl -> Doc ann prettyStandaloneDeriving decl = @@ -1150,13 +1142,13 @@ -- nodes in the correct positions (inserted by 'addExprParens'). -- -- >>> let expr = EApp (EVar "f") (EParen (EInfix (EVar "x") "+" (EVar "y"))) in (renderDoc (prettyExpr expr), show (shorthand expr)) --- ("f\n (x\n + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))") +-- ("f\n (x\n + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))") prettyExpr :: Expr -> Doc ann prettyExpr expr = case expr of EApp {} -> prettyApp expr ETypeApp fn ty -> - prettyExpr fn <> hardline <> " " <> prettyTypeAppArg ty + nest 2 (prettyExpr fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty) EVar name -> prettyName name ETypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty ETypeSyntax TypeSyntaxInTerm ty -> prettyType ty @@ -1178,25 +1170,25 @@ ETHSplice body -> "$" <> prettySpliceBody body ETHTypedSplice body -> "$$" <> prettySpliceBody body EIf cond yes no -> - "if" <+> nest 2 (prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no) + "if" <+> prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no EMultiWayIf rhss -> - "if" <+> hang 3 (prettyMultiWayIfRhss rhss) + "if" <+> align (prettyMultiWayIfRhss rhss) ELambdaPats pats body -> - "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> nest 2 (prettyExpr body) + "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyExpr body ELambdaCase alts -> "\\" <> "case" <> prettyCaseLayout (map prettyCaseAlt alts) ELambdaCases alts -> "\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts) EInfix lhs op rhs -> - prettyExpr lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs + nest 2 (prettyExpr lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs) ENegate inner -> "-" <+> prettyExprAtStatementStart inner ESectionL lhs op -> - prettyExpr lhs <> hardline <> " " <> prettyNameInfixOp op + nest 2 (prettyExpr lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op) ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs ELetDecls decls body -> case decls of [] -> prettyLetDecls decls <+> "in" <+> prettyExpr body - _ -> align (prettyLetDecls decls <> hardline <> indent 2 ("in" <+> prettyExpr body)) + _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyExpr body)) ECase scrutinee alts -> prettyCaseExpr prettyCaseLayout scrutinee alts EDo stmts flavor -> @@ -1225,10 +1217,10 @@ EGetFieldProjection fields -> "." <> mconcat (punctuate "." (map prettyName fields)) ETypeSig inner ty -> - align (prettyExpr inner <> hardline <> "::" <+> prettyType ty) + nest 2 (prettyExpr inner) <> nest 1 (hardline <> "::" <+> prettyType ty) EParen inner -> case inner of ECase scrutinee alts -> - parens (prettyCaseExpr prettyCaseLayoutAligned scrutinee alts) + parens (prettyCaseExpr prettyCaseLayout scrutinee alts) -- ESectionR with a '#'-starting op renders as "(# ...)" which the lexer -- reads as TkSpecialUnboxedLParen when UnboxedTuples/UnboxedSums is on. -- A leading space produces "( # ...)" which is unambiguous. @@ -1246,7 +1238,7 @@ let slots = [if i == altIdx then prettyExpr inner else mempty | i <- [0 .. arity - 1]] in hsep ["(#", prettyBarSeparated slots, "#)"] EProc pat body -> - "proc" <+> prettyPattern pat <+> "->" <+> nest 2 (prettyCmd body) + "proc" <+> prettyPattern pat <+> "->" <+> prettyCmd body EPragma pragma inner -> prettyPragma pragma <+> prettyExpr inner EAnn _ sub -> prettyExpr sub @@ -1257,7 +1249,7 @@ prettyAppWith :: (Expr -> Doc ann) -> Expr -> Doc ann prettyAppWith prettyFn expr = let (fn, args) = flattenApps expr - in vsep (prettyFn fn : map (indent 2 . prettyExpr) args) + in prettyFn fn <> nest 2 (hardline <> vsep (map prettyExpr args)) where flattenApps = go [] go args (EAnn _ sub) = go args sub @@ -1268,13 +1260,13 @@ prettyCommaSeparated render items = case map render items of [] -> mempty - rendered -> hang 2 (vsep (punctuate comma rendered)) + rendered -> hsep (punctuate comma rendered) prettyBarSeparated :: [Doc ann] -> Doc ann prettyBarSeparated items = case items of [] -> mempty - firstItem : restItems -> hang 2 (vsep (firstItem : map ("|" <+>) restItems)) + firstItem : restItems -> hang 1 (vsep (firstItem : map ("|" <+>) restItems)) prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann prettyTupleBody tupleFlavor inner = @@ -1289,18 +1281,15 @@ else prettyName (recordFieldName field) <+> "=" <+> prettyExpr (recordFieldValue field) prettyCaseAltWith :: (body -> Doc ann) -> CaseAlt body -> Doc ann -prettyCaseAltWith prettyBody (CaseAlt _ pat rhs) = nest 2 $ +prettyCaseAltWith prettyBody (CaseAlt _ pat rhs) = case rhs of UnguardedRhs _ body whereDecls -> prettyPattern pat <+> "->" - <> hardline - <> indent 2 (prettyBody body) + <+> nest 2 (prettyBody body) <> prettyIndentedWhereClause whereDecls GuardedRhss _ grhss whereDecls -> - prettyPattern pat - <> hardline - <> indent 2 (vsep (map (prettyCaseGuardedRhsBlock prettyBody) grhss)) + prettyGuardedCaseAlt (prettyPattern pat) prettyBody grhss <> prettyIndentedWhereClause whereDecls prettyCaseAlt :: CaseAlt Expr -> Doc ann @@ -1315,8 +1304,7 @@ <> hardline <> " " <> pretty arrow - <> hardline - <> indent 2 (prettyExpr body) + <+> prettyExpr body prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann prettyCaseGuardedRhsBlock prettyBody grhs = @@ -1327,9 +1315,16 @@ <> hardline <> " " <> "->" - <> hardline - <> indent 2 (prettyBody body) + <+> nest 2 (prettyBody body) +prettyGuardedCaseAlt :: Doc ann -> (body -> Doc ann) -> [GuardedRhs body] -> Doc ann +prettyGuardedCaseAlt headDoc prettyBody grhss = + case map (prettyCaseGuardedRhsBlock prettyBody) grhss of + [] -> headDoc + [firstGrhs] -> headDoc <+> firstGrhs + firstGrhs : restGrhss -> + headDoc <+> firstGrhs <> nest 2 (hardline <> vsep restGrhss) + prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann prettyMultiWayIfRhss rhss = vsep (map (prettyGuardedRhsBodyBlock "->") rhss) @@ -1337,13 +1332,14 @@ prettyGuardQualifiersLayout qualifiers = case map prettyGuardQualifier qualifiers of [] -> mempty + [firstQualifier] -> firstQualifier firstQualifier : restQualifiers -> - vsep (firstQualifier : map (indent 2 . (comma <+>)) restQualifiers) + firstQualifier <> nest 2 (hardline <> vsep (map (comma <+>) restQualifiers)) prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann prettyCaseExpr layout scrutinee alts = "case" - <+> nest 2 (prettyExpr scrutinee) + <+> align (prettyExpr scrutinee) <+> "of" <> layout (map prettyCaseAlt alts) @@ -1351,23 +1347,16 @@ prettyCaseLayout [] = " " <> spacedBraces mempty prettyCaseLayout alts = nest 2 (hardline <> vsep alts) -prettyCaseLayoutAligned :: [Doc ann] -> Doc ann -prettyCaseLayoutAligned [] = " " <> spacedBraces mempty -prettyCaseLayoutAligned alts = hang 2 (hardline <> vsep alts) - prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann -prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) = nest 2 $ +prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) = case rhs of UnguardedRhs _ body whereDecls -> hsep (map prettyPattern pats) <+> "->" - <> hardline - <> indent 2 (prettyExpr body) + <+> nest 2 (prettyExpr body) <> prettyIndentedWhereClause whereDecls GuardedRhss _ grhss whereDecls -> - hsep (map prettyPattern pats) - <> hardline - <> indent 2 (vsep (map (prettyCaseGuardedRhsBlock prettyExpr) grhss)) + prettyGuardedCaseAlt (hsep (map prettyPattern pats)) prettyExpr grhss <> prettyIndentedWhereClause whereDecls prettyGuardQualifier :: GuardQualifier -> Doc ann @@ -1382,7 +1371,7 @@ prettyLetDecls decls | null decls = "let" <+> spacedBraces mempty | otherwise = - "let" <+> hang 0 (vsep (concatMap prettyDeclLines decls)) + "let" <+> align (vsep (concatMap prettyDeclLines decls)) prettyDoFlavor :: DoFlavor -> Doc ann prettyDoFlavor DoPlain = "do" @@ -1406,10 +1395,10 @@ prettyDoStmt stmt = case stmt of DoAnn _ inner -> prettyDoStmt inner - DoBind pat expr -> prettyPattern pat <+> "<-" <+> nest 2 (prettyExpr expr) + DoBind pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr DoLetDecls decls -> prettyLetDecls decls -- - DoExpr expr -> hang 2 (prettyExprAtStatementStart expr) + DoExpr expr -> prettyExprAtStatementStart expr DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyDoStmt stmts) -- prettyExprAtStatementStart is a hack to get overloaded labels to align. We always print a space before labels which messes things up. @@ -1419,10 +1408,10 @@ EAnn _ sub -> prettyExprAtStatementStart sub EOverloadedLabel _ raw -> pretty raw EApp {} -> prettyAppWith prettyExprAtStatementStart expr - ETypeApp fn ty -> prettyExprAtStatementStart fn <> hardline <> " " <> prettyTypeAppArg ty - EInfix lhs op rhs -> prettyExprAtStatementStart lhs <> hardline <> prettyNameInfixOp op <+> prettyExpr rhs - ESectionL lhs op -> prettyExprAtStatementStart lhs <> hardline <> " " <> prettyNameInfixOp op - ETypeSig inner ty -> prettyExprAtStatementStart inner <> hardline <> indent 2 ("::" <+> prettyType ty) + ETypeApp fn ty -> nest 2 (prettyExprAtStatementStart fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty) + EInfix lhs op rhs -> nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs) + ESectionL lhs op -> nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op) + ETypeSig inner ty -> nest 2 (prettyExprAtStatementStart inner) <> nest 1 (hardline <> "::" <+> prettyType ty) ERecordUpd base fields -> prettyExprAtStatementStart base <+> braces (hsep (punctuate comma (map prettyBinding fields))) EGetField base field -> @@ -1432,16 +1421,16 @@ -- | Pretty-print an arrow command. prettyCmd :: Cmd -> Doc ann prettyCmd (CmdAnn _ inner) = prettyCmd inner -prettyCmd cmd = nest 2 $ +prettyCmd cmd = case cmd of CmdArrApp lhs HsFirstOrderApp rhs -> prettyExpr lhs <+> "-<" <+> prettyExpr rhs CmdArrApp lhs HsHigherOrderApp rhs -> prettyExpr lhs <+> "-<<" <+> prettyExpr rhs CmdInfix l op r -> - prettyCmd l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r + nest 2 (prettyCmd l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r) CmdDo stmts -> - "do" <> prettyDoLayout prettyCmdStmt stmts + "do" <> nest 2 (prettyDoLayout prettyCmdStmt stmts) CmdIf cond yes no -> "if" <+> prettyExpr cond <+> "then" <+> prettyCmd yes <+> "else" <+> prettyCmd no CmdCase scrut alts -> @@ -1449,7 +1438,7 @@ CmdLet decls body -> case decls of [] -> prettyLetDecls decls <+> "in" <+> prettyCmd body - _ -> align (prettyLetDecls decls <> hardline <> "in" <+> prettyCmd body) + _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyCmd body)) CmdLam pats body -> "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyCmd body CmdApp c e -> @@ -1468,7 +1457,7 @@ DoRecStmt stmts -> "rec" <> nest 2 (prettyDoLayout prettyCmdStmt stmts) prettyCmdAtStatementStart :: Cmd -> Doc ann -prettyCmdAtStatementStart cmd = nest 2 $ +prettyCmdAtStatementStart cmd = case cmd of CmdAnn _ inner -> prettyCmdAtStatementStart inner CmdArrApp lhs HsFirstOrderApp rhs -> @@ -1476,7 +1465,7 @@ CmdArrApp lhs HsHigherOrderApp rhs -> prettyExprAtStatementStart lhs <+> "-<<" <+> prettyExpr rhs CmdInfix l op r -> - prettyCmdAtStatementStart l <> hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r + nest 2 (prettyCmdAtStatementStart l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r) CmdApp c e -> prettyCmdAtStatementStart c <+> prettyExpr e _ -> prettyCmd cmd @@ -1508,13 +1497,9 @@ let guards = guardedRhsGuards grhs body = guardedRhsBody grhs in "|" - <+> nest - 2 - ( prettyGuardQualifiersLayout guards - <> hardline - <> "=" - <+> nest 2 (prettyExpr body) - ) + <+> prettyGuardQualifiersLayout guards + <+> "=" + <+> prettyExpr body prettyArithSeq :: ArithSeq -> Doc ann prettyArithSeq seqInfo = @@ -1553,7 +1538,7 @@ ["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity] eqsPart Nothing = [] eqsPart (Just []) = ["where", spacedBraces mempty] - eqsPart (Just eqs) = ["where" <> hardline <> indent 2 (vsep (map prettyTypeFamilyEq eqs))] + eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> vsep (map prettyTypeFamilyEq eqs))] prettyTypeFamilyEq :: TypeFamilyEq -> Doc ann prettyTypeFamilyEq eq = diff --git a/src/Aihc/Parser/Syntax.hs b/src/Aihc/Parser/Syntax.hs --- a/src/Aihc/Parser/Syntax.hs +++ b/src/Aihc/Parser/Syntax.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE OverloadedStrings #-} -- | @@ -34,6 +35,7 @@ DoStmt (..), Expr (..), Extension (..), + ExtensionSet, ExtensionSetting (..), ExportSpec (..), IEEntityNamespace (..), @@ -112,6 +114,8 @@ binderHeadParams, effectiveExtensions, extensionName, + memberExtension, + mkExtensionSet, extensionSettingName, gadtBodyResultType, languageEditionExtensions, @@ -156,16 +160,19 @@ where import Control.DeepSeq (NFData (..)) +import Data.Bits (setBit, testBit) import Data.Char (GeneralCategory (..), generalCategory) import Data.Data (Constr, Data (..), DataType, Fixity (Prefix), mkConstr, mkDataType) import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn) import Data.List (sort) +import Data.List qualified as List import Data.Map qualified as Map import Data.Maybe (fromMaybe, mapMaybe) import Data.String (IsString (..)) import Data.Text (Text) import Data.Text qualified as T import Data.Typeable (cast) +import Data.Word (Word64) import GHC.Generics (Generic) -- | A @LANGUAGE@ pragma name. @@ -332,6 +339,29 @@ | XmlSyntax deriving (Data, Eq, Ord, Show, Read, Enum, Bounded, Generic, NFData) +data ExtensionSet = ExtensionSet !Word64 !Word64 !Word64 + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +mkExtensionSet :: [Extension] -> ExtensionSet +mkExtensionSet = List.foldl' insertExtension (ExtensionSet 0 0 0) + where + insertExtension (ExtensionSet low middle high) ext = + case fromEnum ext `quotRem` 64 of + (0, bit) -> ExtensionSet (setBit low bit) middle high + (1, bit) -> ExtensionSet low (setBit middle bit) high + (2, bit) -> ExtensionSet low middle (setBit high bit) + _ -> error "mkExtensionSet: extension enum exceeds bitset capacity" + +memberExtension :: Extension -> ExtensionSet -> Bool +memberExtension ext (ExtensionSet low middle high) = + case fromEnum ext `quotRem` 64 of + (0, bit) -> testBit low bit + (1, bit) -> testBit middle bit + (2, bit) -> testBit high bit + _ -> False +{-# INLINE memberExtension #-} + -- | A single @LANGUAGE@ pragma entry. -- Examples: @EnableExtension LambdaCase@ for @{-# LANGUAGE LambdaCase #-}@ and -- @DisableExtension ImplicitPrelude@ for @{-# LANGUAGE NoImplicitPrelude #-}@. @@ -709,7 +739,7 @@ NameVarSym | -- | Constructor operator (e.g., @:@, @:++@) NameConSym - deriving (Eq, Show, Generic, NFData, Enum, Bounded, Data) + deriving (Eq, Show, Read, Generic, NFData, Enum, Bounded, Data) mkName :: Maybe Text -> NameType -> Text -> Name mkName qualifier ty txt = Name qualifier ty txt [] @@ -1844,7 +1874,7 @@ InfixL | -- | @infixr@ InfixR - deriving (Data, Eq, Show, Generic, NFData) + deriving (Data, Eq, Show, Read, Generic, NFData) -- | A foreign import or export declaration. -- Example: @foreign import ccall "puts" puts :: CString -> IO CInt@. @@ -1910,19 +1940,30 @@ deriving (Data, Eq, Show, Generic, NFData) -- | Opaque metadata attached to syntax nodes. --- Example: a stored 'SourceSpan' created with 'mkAnnotation'. -newtype Annotation = Annotation Dynamic +-- +-- Parsed syntax overwhelmingly attaches 'SourceSpan' annotations, so spans get +-- a direct representation. Later compiler stages can still attach arbitrary +-- typed metadata through the dynamic fallback. +data Annotation + = SourceSpanAnnotation !SourceSpan + | DynamicAnnotation Dynamic deriving (Show, Generic) mkAnnotation :: (Typeable a) => a -> Annotation -mkAnnotation = Annotation . toDyn +mkAnnotation value = + case cast value of + Just span' -> SourceSpanAnnotation span' + Nothing -> DynamicAnnotation (toDyn value) +{-# INLINE mkAnnotation #-} fromAnnotation :: (Typeable a) => Annotation -> Maybe a -fromAnnotation (Annotation value) = fromDynamic value +fromAnnotation (SourceSpanAnnotation span') = cast span' +fromAnnotation (DynamicAnnotation value) = fromDynamic value +{-# INLINE fromAnnotation #-} instance Data Annotation where gfoldl _ z = z - gunfold _ z _ = z (Annotation (toDyn ())) + gunfold _ z _ = z (SourceSpanAnnotation NoSourceSpan) toConstr _ = annotationConstr dataTypeOf _ = annotationDataType @@ -1936,7 +1977,8 @@ _ == _ = True instance NFData Annotation where - rnf (Annotation _) = () + rnf (SourceSpanAnnotation span') = rnf span' + rnf (DynamicAnnotation _) = () -- | An expression. data Expr diff --git a/src/Aihc/Parser/Types.hs b/src/Aihc/Parser/Types.hs --- a/src/Aihc/Parser/Types.hs +++ b/src/Aihc/Parser/Types.hs @@ -29,7 +29,7 @@ readModuleHeaderExtensions, scanAllTokens, ) -import Aihc.Parser.Syntax (Extension, SourceSpan, applyExtensionSetting, applyImpliedExtensions) +import Aihc.Parser.Syntax (Extension, ExtensionSet, SourceSpan, applyExtensionSetting, applyImpliedExtensions, mkExtensionSet) import Control.DeepSeq (NFData (..)) import Data.Text (Text) import Data.Text qualified as T @@ -81,14 +81,16 @@ data TokStream = TokStream { -- | Shared lazy list of raw tokens (never re-scanned on backtrack). tokStreamRawTokens :: [LexToken], - -- | Layout engine state (context stack, pending layout, buffer). + -- | Layout engine state (context stack and pending layout). tokStreamLayoutState :: LayoutState, + -- | Tokens ready for the parser, including virtual layout tokens. + tokStreamBuffer :: [LexToken], -- | Hidden pragmas that appeared before the next source token. -- Parsers may inspect these explicitly, but they never participate in the -- ordinary token stream. tokStreamPendingPragmas :: [Pragma], tokStreamPrevToken :: Maybe LexToken, - tokStreamExtensions :: [Extension], + tokStreamExtensionSet :: ExtensionSet, -- | Whether this stream has already emitted TkEOF. -- After EOF is emitted, 'take1_' returns Nothing. tokStreamEOFEmitted :: !Bool @@ -118,8 +120,8 @@ <> show (length (tokStreamPendingPragmas ts)) <> ", prevToken = " <> show (tokStreamPrevToken ts) - <> ", extensions = " - <> show (tokStreamExtensions ts) + <> ", extensionSet = " + <> show (tokStreamExtensionSet ts) <> " }" -- Manual NFData instance — don't force the lazy raw token list. @@ -127,7 +129,7 @@ rnf ts = rnf (tokStreamPendingPragmas ts) `seq` rnf (tokStreamPrevToken ts) `seq` - rnf (tokStreamExtensions ts) `seq` + rnf (tokStreamExtensionSet ts) `seq` rnf (tokStreamEOFEmitted ts) -- | Create a TokStream for parsing expressions/declarations (no module layout). @@ -138,9 +140,10 @@ TokStream { tokStreamRawTokens = scanAllTokens env lexSt, tokStreamLayoutState = mkInitialLayoutState False exts, + tokStreamBuffer = [], tokStreamPendingPragmas = [], tokStreamPrevToken = Nothing, - tokStreamExtensions = exts, + tokStreamExtensionSet = mkExtensionSet exts, tokStreamEOFEmitted = False } @@ -153,9 +156,10 @@ TokStream { tokStreamRawTokens = scanAllTokens env lexSt, tokStreamLayoutState = mkInitialLayoutState True effectiveExts, + tokStreamBuffer = [], tokStreamPendingPragmas = [], tokStreamPrevToken = Nothing, - tokStreamExtensions = effectiveExts, + tokStreamExtensionSet = mkExtensionSet effectiveExts, tokStreamEOFEmitted = False } where @@ -170,57 +174,62 @@ in normalizeTokStream TokStream { tokStreamRawTokens = scanAllTokens env lexSt, - tokStreamLayoutState = - (mkInitialLayoutState False []) - { layoutBuffer = toks - }, + tokStreamLayoutState = mkInitialLayoutState False [], + tokStreamBuffer = toks, tokStreamPendingPragmas = [], tokStreamPrevToken = Nothing, - tokStreamExtensions = [], + tokStreamExtensionSet = mkExtensionSet [], tokStreamEOFEmitted = False } -pragmaFromToken :: LexToken -> Maybe Pragma -pragmaFromToken tok = - case lexTokenKind tok of - TkPragma pragma' -> Just pragma' - _ -> Nothing - -isHiddenToken :: LexToken -> Bool -isHiddenToken tok = - case lexTokenKind tok of - TkPragma _ -> True - TkLineComment -> True - TkBlockComment -> True - _ -> False - normalizeTokStream :: TokStream -> TokStream normalizeTokStream ts0 | tokStreamEOFEmitted ts0 = ts0 - | otherwise = go ts0 + | otherwise = + normalizeTokStreamParts + (tokStreamRawTokens ts0) + (tokStreamLayoutState ts0) + (tokStreamBuffer ts0) + (tokStreamPendingPragmas ts0) + (tokStreamPrevToken ts0) + (tokStreamExtensionSet ts0) + False + +-- | Advance through layout and hidden tokens until the stream is ready for +-- 'stepOne'. Keeping the stream fields separate lets a token step normalize +-- its successor without first allocating an intermediate 'TokStream'. +normalizeTokStreamParts :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> TokStream +normalizeTokStreamParts rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted + | eofEmitted = finish rawTokens layoutState buffer pendingPragmas + | otherwise = go rawTokens layoutState buffer pendingPragmas where - go ts = - case layoutBuffer (tokStreamLayoutState ts) of - tok : rest - | Just pragma' <- pragmaFromToken tok -> - go - ts - { tokStreamLayoutState = (tokStreamLayoutState ts) {layoutBuffer = rest}, - tokStreamPendingPragmas = tokStreamPendingPragmas ts <> [pragma'] - } - | isHiddenToken tok -> - go - ts - { tokStreamLayoutState = (tokStreamLayoutState ts) {layoutBuffer = rest} - } - | otherwise -> ts + finish rawTokens' layoutState' buffer' pendingPragmas' = + TokStream + { tokStreamRawTokens = rawTokens', + tokStreamLayoutState = layoutState', + tokStreamBuffer = buffer', + tokStreamPendingPragmas = pendingPragmas', + tokStreamPrevToken = prevToken, + tokStreamExtensionSet = extensionSet, + tokStreamEOFEmitted = eofEmitted + } + + go rawTokens' layoutState' buffer' pendingPragmas' = + case buffer' of + tok : rest -> + case lexTokenKind tok of + TkPragma pragma' -> + go rawTokens' layoutState' rest (pendingPragmas' <> [pragma']) + TkLineComment -> go rawTokens' layoutState' rest pendingPragmas' + TkBlockComment -> go rawTokens' layoutState' rest pendingPragmas' + _ -> finish rawTokens' layoutState' buffer' pendingPragmas' [] -> - case tokStreamRawTokens ts of - [] -> ts + case rawTokens' of + [] -> finish [] layoutState' [] pendingPragmas' rawTok : rawRest -> - let (allToks, laySt') = layoutTransition (tokStreamLayoutState ts) rawTok - laySt'' = laySt' {layoutBuffer = allToks} - in go ts {tokStreamRawTokens = rawRest, tokStreamLayoutState = laySt''} + let (allToks, laySt') = layoutTransition layoutState' rawTok + in go rawRest laySt' allToks pendingPragmas' +{-# INLINE normalizeTokStreamParts #-} -- | Step one token from the stream. This is the core primitive used by all -- Stream methods. @@ -239,29 +248,33 @@ stepOne ts | tokStreamEOFEmitted ts = Nothing | otherwise = - let ts0 = normalizeTokStream ts - laySt = tokStreamLayoutState ts0 - in case layoutBuffer laySt of - -- Drain buffered tokens first (virtual braces/semicolons) - tok : rest -> - let isEOF = lexTokenKind tok == TkEOF - pendingPragmas = - case lexTokenOrigin tok of - InsertedLayout -> tokStreamPendingPragmas ts0 - FromSource - | lexTokenKind tok == TkSpecialSemicolon -> tokStreamPendingPragmas ts0 - | otherwise -> [] - ts' = - ts0 - { tokStreamLayoutState = laySt {layoutBuffer = rest}, - tokStreamPendingPragmas = pendingPragmas, - tokStreamPrevToken = Just tok, - tokStreamEOFEmitted = isEOF - } - in Just - (tok, normalizeTokStream ts') - [] -> - Nothing + case tokStreamBuffer ts of + -- Drain buffered tokens first (virtual braces/semicolons) + tok : rest -> + let kind = lexTokenKind tok + isEOF = case kind of + TkEOF -> True + _ -> False + pendingPragmas = + case lexTokenOrigin tok of + InsertedLayout -> tokStreamPendingPragmas ts + FromSource + | TkSpecialSemicolon <- kind -> tokStreamPendingPragmas ts + | otherwise -> [] + in Just + ( tok, + normalizeTokStreamParts + (tokStreamRawTokens ts) + (tokStreamLayoutState ts) + rest + pendingPragmas + (Just tok) + (tokStreamExtensionSet ts) + isEOF + ) + [] -> + Nothing +{-# INLINE stepOne #-} instance Stream TokStream where type Token TokStream = LexToken @@ -277,16 +290,15 @@ takeN_ n ts | n <= 0 = Just ([], ts) - | otherwise = - case stepOne ts of - Nothing -> Nothing - Just (tok, ts') -> - let go 1 acc s = Just (reverse (tok : acc), s) - go k acc s = - case stepOne s of - Nothing -> Just (reverse (tok : acc), s) - Just (t, s') -> go (k - 1) (t : acc) s' - in go n [] ts' + | otherwise = go n [] ts + where + go 0 acc s = Just (reverse acc, s) + go k acc s = + case stepOne s of + Nothing + | null acc -> Nothing + | otherwise -> Just (reverse acc, s) + Just (tok, s') -> go (k - 1) (tok : acc) s' takeWhile_ f = go [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -15,7 +15,7 @@ import CppSupport (preprocessForParserWithoutIncludesIfEnabled) import Data.Char (ord) import Data.Data (Data, dataTypeConstrs, dataTypeOf, gmapQl, isAlgType, showConstr, toConstr) -import Data.Maybe (isNothing) +import Data.Maybe (isNothing, mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -217,6 +217,7 @@ testCase "shrunk module headers without warnings make progress" test_shrunkModuleHeaderWithoutWarningMakesProgress, testCase "syntax utility functions cover public edge cases" test_syntaxUtilityFunctions, testCase "shrunk class default pattern binds make progress" test_shrunkClassDefaultPatternBindMakesProgress, + testCase "parsed binders carry source spans" test_parsedBindersCarrySourceSpans, testCase "shrunk arrow command infix lhs modules make progress" test_shrunkArrowCommandInfixLhsModuleMakesProgress, testCase "shrunk wildcard pattern binds do not cycle" test_shrunkWildcardPatternBindsDoNotCycle, testCase "shrunk infix expression left operands do not cycle" test_shrunkInfixExprLeftOperandsDoNotCycle, @@ -464,7 +465,7 @@ EParen (EOverloadedLabel "a" "#a") ] rendered = map (renderStrict . layoutPretty defaultLayoutOptions . pretty) exprs - expected = ["( #a,\n )", "[ #a]", "( #a)"] + expected = ["( #a, )", "[ #a]", "( #a)"] assertEqual "pretty-printed forms" expected rendered mapM_ ( \source -> @@ -523,6 +524,38 @@ assertBool ("expected no parse errors, got: " <> show errs) (null errs) assertEqual "expected two declarations" 2 (length (moduleDecls modu)) +test_parsedBindersCarrySourceSpans :: Assertion +test_parsedBindersCarrySourceSpans = + let source = + T.unlines + [ "data T a = MkT { field :: a } | a :*: a", + "f x = x", + "(+) x y = x", + "foreign import ccall \"foo\" c_foo :: ()" + ] + (errs, modu) = parseModule defaultConfig source + in do + assertBool ("expected no parse errors, got: " <> show errs) (null errs) + case moduleDecls modu of + [ DeclAnn _ (DeclData dataDecl), + DeclAnn _ (DeclValue (FunctionBind valueName _)), + DeclAnn _ (DeclValue (FunctionBind operatorName _)), + DeclAnn _ (DeclForeign foreignDecl) + ] -> do + assertUnqualifiedNameSpan "type constructor" "" 1 6 1 7 5 6 (binderHeadName (dataDeclHead dataDecl)) + case dataDeclConstructors dataDecl of + [ DataConAnn _ (RecordCon _ _ recordCon [FieldDecl {fieldNames = [fieldName]}]), + DataConAnn _ (InfixCon _ _ _ infixCon _) + ] -> do + assertUnqualifiedNameSpan "record constructor" "" 1 12 1 15 11 14 recordCon + assertUnqualifiedNameSpan "record field" "" 1 18 1 23 17 22 fieldName + assertUnqualifiedNameSpan "infix constructor" "" 1 35 1 38 34 37 infixCon + other -> assertFailure ("expected record and infix constructors, got: " <> show other) + assertUnqualifiedNameSpan "value binder" "" 2 1 2 2 40 41 valueName + assertUnqualifiedNameSpan "operator binder" "" 3 2 3 3 49 50 operatorName + assertUnqualifiedNameSpan "foreign binder" "" 4 28 4 33 87 92 (foreignName foreignDecl) + other -> assertFailure ("expected data, value, operator, and foreign declarations, got: " <> show other) + test_emptyCaseLayoutAtEof :: Assertion test_emptyCaseLayoutAtEof = let source = "x = case () of" @@ -605,6 +638,12 @@ assertEqual "end offset" expectedEndOffset sourceSpanEndOffset NoSourceSpan -> assertFailure "expected SourceSpan, got NoSourceSpan" +assertUnqualifiedNameSpan :: String -> FilePath -> Int -> Int -> Int -> Int -> Int -> Int -> UnqualifiedName -> Assertion +assertUnqualifiedNameSpan label expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset name = + case mapMaybe (fromAnnotation :: Annotation -> Maybe SourceSpan) (unqualifiedNameAnns name) of + span' : _ -> assertSourceSpan expectedName expectedStartLine expectedStartCol expectedEndLine expectedEndCol expectedStartOffset expectedEndOffset span' + [] -> assertFailure ("expected SourceSpan annotation for " <> label <> ", got none") + assertReadRoundTrip :: (Eq a, Read a, Show a) => String -> [a] -> Assertion assertReadRoundTrip label = mapM_ $ \value -> @@ -968,7 +1007,8 @@ in case errs of [] -> case moduleHead modu of - Just ModuleHead {moduleHeadExports = Just [ExportAnn _ (ExportVar _ _ name)]} | name == qualifyName Nothing (mkUnqualifiedName NameVarId "f##") -> pure () + Just ModuleHead {moduleHeadExports = Just [ExportAnn _ (ExportVar _ _ name)]} + | stripAnnotations name == qualifyName Nothing (mkUnqualifiedName NameVarId "f##") -> pure () other -> assertFailure ("expected export of f##, got: " <> show other) _ -> assertFailure ("expected parse success for MagicHash export, got: " <> formatParseErrors "" (Just source) errs) @@ -1197,10 +1237,10 @@ in do assertBool ("expected no parse errors, got: " <> show errs) (null errs) assertBool ("expected reparsed pretty output to succeed, got: " <> show reparseErrs) (null reparseErrs) - case moduleExports modu of - Just [ExportAnn _ (ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"])] -> - case moduleExports reparsed of - Just [ExportAnn _ (ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"])] -> + case moduleExports (stripAnnotations modu) of + Just [ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"]] -> + case moduleExports (stripAnnotations reparsed) of + Just [ExportWithAll _ Nothing "T" 0 [IEBundledMember Nothing "P", IEBundledMember (Just IEBundledNamespaceData) "Q"]] -> pure () other -> assertFailure ("unexpected reparsed export AST: " <> show other) @@ -1615,8 +1655,8 @@ expected = """ f [case [] of { } - + [] - -> _] = [] + + [] + -> _] = [] """ assertParsedModulePrettyContains source expected @@ -2034,7 +2074,7 @@ case map peelDeclAnn (moduleDecls modu) of [ DeclClass ClassDecl {classDeclItems = [ClassItemAnn _ (ClassItemDataFamilyDecl dataFamilyDecl)]} ] - | binderHeadName (dataFamilyDeclHead dataFamilyDecl) == expectedName, + | stripAnnotations (binderHeadName (dataFamilyDeclHead dataFamilyDecl)) == expectedName, map tyVarBinderName (binderHeadParams (dataFamilyDeclHead dataFamilyDecl)) == ["a"], isNothing (dataFamilyDeclKind dataFamilyDecl) -> pure () @@ -2053,7 +2093,7 @@ [ DeclClass ClassDecl {classDeclItems = [ClassItemAnn _ (ClassItemDataFamilyDecl dataFamilyDecl)]} ] | binderHeadForm (dataFamilyDeclHead dataFamilyDecl) == TypeHeadInfix, - binderHeadName (dataFamilyDeclHead dataFamilyDecl) == expectedName, + stripAnnotations (binderHeadName (dataFamilyDeclHead dataFamilyDecl)) == expectedName, map tyVarBinderName (binderHeadParams (dataFamilyDeclHead dataFamilyDecl)) == ["a", "b"], isNothing (dataFamilyDeclKind dataFamilyDecl) -> pure () diff --git a/test/Test/Fixtures/lexer/core/string-hash-latin1.yaml b/test/Test/Fixtures/lexer/core/string-hash-latin1.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-hash-latin1.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: '"\xFF\0bar"#' +tokens: + - 'TkStringHash "\255\NULbar" "\"\\xFF\\0bar\"#"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/string-hash-non-latin1.yaml b/test/Test/Fixtures/lexer/core/string-hash-non-latin1.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-hash-non-latin1.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: '"\x3B1"#' +tokens: + - 'TkError "primitive string literal contains a character outside Latin-1"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/lexer/core/string-non-latin1-boxed.yaml b/test/Test/Fixtures/lexer/core/string-non-latin1-boxed.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/lexer/core/string-non-latin1-boxed.yaml @@ -0,0 +1,6 @@ +extensions: [MagicHash] +input: '"\x3B1"' +tokens: + - 'TkString "\945"' + - 'TkEOF' +status: pass diff --git a/test/Test/Fixtures/oracle/Hackage/boltzmann-samplers-infix-case-scrutinee.hs b/test/Test/Fixtures/oracle/Hackage/boltzmann-samplers-infix-case-scrutinee.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Hackage/boltzmann-samplers-infix-case-scrutinee.hs @@ -0,0 +1,15 @@ +{- ORACLE_TEST pass -} +module M where + +infixl 9 #! + +(#!) = undefined + +data A = SomeData B + +data B = AlgRep Int | Other + +phi xedni i = case xedni #! i of + SomeData a -> case a of + AlgRep _ -> \_ _ -> 0 + Other -> \x _ -> x diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout001-case-where.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout001-case-where.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout001-case-where.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout001.hs. +module M where + +f = case () of + () -> () + where x = x diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout002-if-then-do.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout002-if-then-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout002-if-then-do.hs @@ -0,0 +1,5 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout002.hs. +module M where + +f = if True then do undefined else undefined diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout003-list-comprehension-closes-do.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout003-list-comprehension-closes-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout003-list-comprehension-closes-do.hs @@ -0,0 +1,12 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout003.hs. +module M where + +-- The array package used to have things in this sort of pattern, where +-- the "parse error" rule is needed to close the do block's layout + +f :: [IO ()] +f = [do + undefined + undefined + | _ <- undefined] diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout004-pattern-guard-let.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout004-pattern-guard-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout004-pattern-guard-let.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout004.hs. +{-# LANGUAGE PatternGuards #-} + +module M where + +f | Just x <- undefined, + let y = x, + undefined x y + = () diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout005-else-closes-do.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout005-else-closes-do.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout005-else-closes-do.hs @@ -0,0 +1,10 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout005.hs. +module M where + +-- GHC's Lexer.x had a piece of code like this + +f = if True then do + case () of + () -> () + else () diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout006-guarded-do-let.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout006-guarded-do-let.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout006-guarded-do-let.hs @@ -0,0 +1,13 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout006.hs. +module M where + +-- GHC's GHC.Parser.PostProcess had a piece of code like this + +f :: IO () +f + | True = do + let x = () + y = () + return () + | True = return () diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout007-splice-closing-paren.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout007-splice-closing-paren.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout007-splice-closing-paren.hs @@ -0,0 +1,11 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout007.hs. +{-# LANGUAGE TemplateHaskell #-} + +module M where + +-- The paren here closes the open-splice - it doesn't match an +-- opening paren + +f :: IO () +f = do print $( [| 'a' |] ) diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout008-do-mdo-rec.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout008-do-mdo-rec.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout008-do-mdo-rec.hs @@ -0,0 +1,22 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout008.hs. +{-# LANGUAGE RecursiveDo, DoRec #-} +{-# OPTIONS_GHC -fno-warn-deprecated-flags #-} + +module M where + +-- do, mdo and rec should all open layouts + +f :: IO () +f = do print 'a' + print 'b' + +g :: IO () +g = mdo print 'a' + print 'b' + +h :: IO () +h = do print 'a' + rec print 'b' + print 'c' + print 'd' diff --git a/test/Test/Fixtures/oracle/Layout/ghc-layout009-explicit-let-braces.hs b/test/Test/Fixtures/oracle/Layout/ghc-layout009-explicit-let-braces.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/Layout/ghc-layout009-explicit-let-braces.hs @@ -0,0 +1,6 @@ +{- ORACLE_TEST pass -} +-- From GHC testsuite/tests/layout/layout009.hs. +module M where + +f :: Char +f = let {x = 'a'} in x diff --git a/test/Test/Fixtures/oracle/PatternSyntax/variable-leading-infix-declarations.hs b/test/Test/Fixtures/oracle/PatternSyntax/variable-leading-infix-declarations.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/PatternSyntax/variable-leading-infix-declarations.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE GHC2021 #-} + +module VariableLeadingInfixDeclarations where + +a@_ + _ = [] +b :+ _ = [] diff --git a/test/Test/Fixtures/oracle/TransformListComp/bare-if-boundaries.hs b/test/Test/Fixtures/oracle/TransformListComp/bare-if-boundaries.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/bare-if-boundaries.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} + +module BareIfBoundaries where + +thenIf = [[] | then if [] then [] else [] by []] + +groupByIf = [[] | then group by if [] then [] else [] using []] diff --git a/test/Test/Performance/Suite.hs b/test/Test/Performance/Suite.hs --- a/test/Test/Performance/Suite.hs +++ b/test/Test/Performance/Suite.hs @@ -218,7 +218,7 @@ mkGeneratedPerfCase "type-right-leaning-terms" (mkTypeModule (rightLeaningType generatedCaseSize)), mkGeneratedPerfCase "type-left-leaning-terms" (mkTypeModule (leftLeaningType generatedCaseSize)), mkGeneratedPerfCase "type-parameters" (mkTypeModule (typeWithParameters generatedCaseSize)), - mkGeneratedPerfCase "string-escapes" (mkExprModule (escapedStringExpr (generatedCaseSize * 100))), + mkGeneratedPerfCase "string-escapes" (mkExprModule (escapedStringExpr (generatedCaseSize * 500))), mkGeneratedPerfCase "nested-application" (mkExprModule (nestedAppExpr generatedCaseSize)), mkGeneratedPerfCaseWithStatus "xfail-invalid-module" "module Generated where\nvalue = { x = 1, }\n" StatusXFail "regression coverage" ] @@ -315,7 +315,7 @@ escapedStringExpr :: Int -> Text escapedStringExpr desiredLength = - T.concat ["\"", takeEscapedText desiredLength escapedStringFragments, "\""] + T.concat ["\"", takeEscapedText desiredLength (cycle escapedStringFragments), "\""] escapedStringFragments :: [Text] escapedStringFragments = diff --git a/test/Test/Properties/NoExceptions.hs b/test/Test/Properties/NoExceptions.hs --- a/test/Test/Properties/NoExceptions.hs +++ b/test/Test/Properties/NoExceptions.hs @@ -17,21 +17,19 @@ ) where -import Aihc.Parser.Internal.FromTokens - ( parseDeclFromTokens, +import Aihc.Parser.Internal.Testing + ( LexToken (..), + LexTokenKind (..), + TokenOrigin (..), + lexModuleTokens, + lexTokens, + parseDeclFromTokens, parseExprFromTokens, parseImportDeclFromTokens, parseModuleFromTokens, parseModuleHeaderFromTokens, parsePatternFromTokens, parseTypeFromTokens, - ) -import Aihc.Parser.Lex - ( LexToken (..), - LexTokenKind (..), - TokenOrigin (..), - lexModuleTokens, - lexTokens, ) import Aihc.Parser.Syntax (ExtensionSetting (..), FloatType (..), NumericType (..), SourceSpan (..)) import Aihc.Parser.Syntax qualified as Syntax diff --git a/test/Test/Properties/ShorthandSubset.hs b/test/Test/Properties/ShorthandSubset.hs --- a/test/Test/Properties/ShorthandSubset.hs +++ b/test/Test/Properties/ShorthandSubset.hs @@ -9,9 +9,9 @@ ) where -import Aihc.Parser.Lex (LexToken) import Aihc.Parser.Shorthand (Shorthand (shorthand)) import Aihc.Parser.Syntax +import Aihc.Parser.Token (LexToken) import Data.Char (isAlphaNum, isSpace) import Data.List (isSubsequenceOf) import Test.Properties.Arb.Decl ()