diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,66 @@ ## [Unreleased] +## [6.0.0.0] - 2026-11-12 + +### Added + +- The parser accepts n+k patterns, for example `f (n+1) = n`, when the + `NPlusKPatterns` extension is on. `Haskell98` turns on this extension. The + new `PNPlusK` constructor of `Pattern` holds the variable and the integer + literal. A function or pattern that matches on all `Pattern` constructors + must add a case for `PNPlusK`. +- With `NPlusKPatterns` on, `(n+1) = e` is a pattern binding, as in GHC. + Without parentheses, `n + 1 = e` is still a definition of `(+)`. +- `parseModuleWithTrace` parses a module and also returns its token trace. + The trace has each token that the parser took, in order. It has real + tokens and virtual layout tokens. A `TraceEntry` marks each token that the + parser took but did not keep in the AST, for example a trailing comma, an + extra semicolon, or the parentheses of `data (T a) = …`. +- `tokenKindWithoutSpacing` maps a token kind to the kind that it has with + spaces around it, for example `TkPrefixPercent` to `TkVarSym "%"`. +- When the discarded entries are removed, a module and its pretty-printed + form have the same trace token kinds. A formatter can use this to pair the + tokens of the two texts. + +### Changed + +- The pretty-printer puts an expression on one line when it fits in the + page width. For example, it prints `f x = x + 1` on one line. Before, it + put each operator and each function argument on a new line. A long + expression still breaks at the same points as before. Layout blocks + (`do`, `case`, `where`, `let`, guards, and multi-way `if`) still start new + lines where the layout rule needs them. +- When a function application does not fit, the pretty-printer puts as many + arguments on a line as fit. Before, it put each argument on its own line. + After an argument that ends with a layout block, a new line still starts. +- When a record construction, a record update, a list, or a tuple does not + fit, the pretty-printer starts a new line after each comma. Before, it kept + all items on one line. +- When a function type does not fit, each argument after the first starts a + new line with its arrow. A context that does not fit puts the rest on a new + line after `=>`. This also applies to instance heads and class heads. +- When a `data` or `newtype` declaration does not fit, each constructor and + each deriving clause starts a new line. A record declaration that does not + fit starts a new line after each field. +- When an import list or an export list does not fit, each line gets as many + items as fit. + +### Fixed + +- The pretty-printer does not put parentheses around a `case` expression + before `by` or `using` in a TransformListComp statement. With + TransformListComp, these words are keywords and they close the case + alternatives. Before, GHC read the printed module with an extra `HsPar`. +- The pretty-printer also does not put parentheses around a multi-way `if` + before `by` or `using` in a TransformListComp statement. The keyword + closes the alternatives of the multi-way `if`. +- The pretty-printer puts the alternatives of a multi-way `if` to the right of + the current indentation. Before, a continuation line of the expression + around the `if` could start at the column of the `|` of an alternative. The + parser then read that line as part of the last alternative, and the printed + module did not parse to the same syntax tree. + ## [5.0.1.0] - 2026-10-21 ### Added diff --git a/aihc-parser.cabal b/aihc-parser.cabal --- a/aihc-parser.cabal +++ b/aihc-parser.cabal @@ -1,6 +1,6 @@ cabal-version: 3.8 name: aihc-parser -version: 5.0.1.0 +version: 6.0.0.0 build-type: Simple license: Unlicense license-file: LICENSE diff --git a/common/ExtensionSupport.hs b/common/ExtensionSupport.hs --- a/common/ExtensionSupport.hs +++ b/common/ExtensionSupport.hs @@ -12,6 +12,7 @@ finalizeOutcome, evaluateCaseFromFile, evaluateCaseText, + preprocessCaseSource, ) where @@ -80,18 +81,22 @@ evaluateCaseText :: CaseMeta -> Text -> (CaseMeta, Outcome, String) evaluateCaseText meta source = let exts = caseExtensions meta - source' = - resultOutput - ( preprocessForParserWithoutIncludesIfEnabled - (caseExtensions meta) - [] - (casePath meta) - [] - source - ) + source' = preprocessCaseSource meta source oracleOk = either Just (const Nothing) (oracleModuleAstFingerprint (casePath meta) Syntax.Haskell2010Edition exts source') validationOk = fmap show (validateParser (casePath meta) Syntax.Haskell2010Edition exts source') in finalizeOutcome meta oracleOk validationOk + +-- | Run CPP on the source of a case when the case enables it. +preprocessCaseSource :: CaseMeta -> Text -> Text +preprocessCaseSource meta source = + resultOutput + ( preprocessForParserWithoutIncludesIfEnabled + (caseExtensions meta) + [] + (casePath meta) + [] + source + ) trim :: String -> String trim = dropWhile isSpace . dropWhileEnd isSpace diff --git a/src/Aihc/Parser.hs b/src/Aihc/Parser.hs --- a/src/Aihc/Parser.hs +++ b/src/Aihc/Parser.hs @@ -13,6 +13,9 @@ module Aihc.Parser ( -- * Parsing modules parseModule, + parseModuleWithTrace, + TraceEntry (..), + tokenKindWithoutSpacing, -- * Configuration ParserConfig (..), @@ -38,6 +41,7 @@ import Aihc.Parser.Internal.Module (moduleParser) import Aihc.Parser.Internal.Pattern (patternParser) import Aihc.Parser.Internal.Type (typeParser, typeSignatureParser) +import Aihc.Parser.Lex (LexTokenKind (..)) import Aihc.Parser.Pretty () import Aihc.Parser.Syntax (Decl, Expr, Extension, Module (..), Pattern, SourceSpan, Type, applyImpliedExtensions, sourceSpanEndCol, sourceSpanSourceName, sourceSpanStartCol, sourceSpanStartLine, sourceSpanStartOffset, pattern SourceSpan) import Aihc.Parser.Types @@ -49,6 +53,7 @@ import Data.Word (Word8) import Prettyprinter (Doc, colon, defaultLayoutOptions, layoutPretty, pretty, vcat) import Prettyprinter.Render.String (renderString) +import Text.Megaparsec qualified as MP -- $setup -- >>> :set -XOverloadedStrings @@ -143,7 +148,47 @@ -- Nothing parseModule :: ParserConfig -> Text -> ([(SourceSpan, Text)], Module) parseModule cfg input = - case runTokStreamParser parser sourceName (mkTokStreamModule sourceName exts input) of + let (errs, modu, _) = parseModuleWith id cfg input + in (errs, modu) + +-- | Parse a module and return the token trace with it. +-- +-- The trace is each token that the parser took, in order. It contains real +-- tokens and virtual layout tokens, also the virtual close braces that the +-- parser inserts for the parse-error rule. Comments and pragmas are not in +-- the trace. A token that the parser took but did not keep in the AST, for +-- example a trailing comma, has 'traceDiscarded' set. +-- +-- Two modules with the same AST have the same trace token kinds when the +-- discarded entries are removed. A formatter can use this to pair the tokens +-- of a source file with the tokens of its pretty-printed form. +parseModuleWithTrace :: ParserConfig -> Text -> ([(SourceSpan, Text)], Module, [TraceEntry]) +parseModuleWithTrace = parseModuleWith enableTokStreamTrace + +-- | Map a token kind to the kind that it has with spaces around it. +-- +-- The lexer gives some operators a different kind when no space separates +-- them from the next or the previous token. For example, @(%1)@ has +-- 'TkPrefixPercent' but @(% 1)@ has @'TkVarSym' "%"@. The text and the AST +-- are the same, so compare trace entries with this function. It also maps +-- the linear arrow @⊸@ to @->@, because the trace of @%1 ->@ keeps only the +-- arrow. +tokenKindWithoutSpacing :: LexTokenKind -> LexTokenKind +tokenKindWithoutSpacing kind = + case kind of + TkPrefixMinus -> TkMinusOperator + TkPrefixBang -> TkVarSym "!" + TkPrefixTilde -> TkVarSym "~" + TkPrefixPercent -> TkVarSym "%" + TkRecordDot -> TkVarSym "." + TkTypeApp -> TkVarSym "@" + TkReservedAt -> TkVarSym "@" + TkLinearArrow -> TkReservedRightArrow + _ -> kind + +parseModuleWith :: (TokStream -> TokStream) -> ParserConfig -> Text -> ([(SourceSpan, Text)], Module, [TraceEntry]) +parseModuleWith prepare cfg input = + case runTokStreamParser parser sourceName (prepare (mkTokStreamModule sourceName exts input)) of Left bundle -> ( parseErrorBundleToSpannedText sourceName errorStream bundle, Module @@ -152,10 +197,11 @@ moduleLanguagePragmas = [], moduleImports = [], moduleDecls = [] - } + }, + [] ) - Right (errs, modu) -> - (parseErrorsToSpannedText sourceName errorStream errs, modu) + Right (errs, modu, trace) -> + (parseErrorsToSpannedText sourceName errorStream errs, modu, trace) where sourceName = parserSourceName cfg exts = applyImpliedExtensions (parserExtensions cfg) @@ -163,7 +209,8 @@ parser = do modu <- moduleParser errs <- drainParseErrors - pure (errs, modu) + ts <- MP.getInput + pure (errs, modu, maybe [] (reverse . traceEntries) (tokStreamTrace ts)) -- | Run a parser over freshly lexed input. Errors are located on a stream -- built again from the input, so the parse itself does not retain the token 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 @@ -10,27 +10,37 @@ -- \"parse as expression, then reclassify\" strategy described in -- @docs\/unified-expr-pattern-parsing.md@. -- --- The core function 'checkPattern' performs a structural recursion over +-- The core function 'checkPatternWith' performs a structural recursion over -- 'Expr', converting each expression node into its pattern counterpart. -- Expression-only constructs (if, case, do, lambda, etc.) are rejected -- with a descriptive error message. module Aihc.Parser.Internal.CheckPattern ( checkPattern, - checkPatterns, + checkPatternWith, ) where -import Aihc.Parser.Internal.Common (isConLikeName, nameToUnqualified) +import Aihc.Parser.Internal.Common (TokParser, isConLikeName, isExtensionEnabled, liftCheck, nameToUnqualified) import Aihc.Parser.Syntax import Data.Maybe (isJust, isNothing) import Data.Text (Text) +-- | Convert an expression tree into a pattern in the parser. +-- The parser fails with a diagnostic message if the expression cannot be +-- interpreted as a valid pattern. The enabled extensions control which +-- patterns are valid. +checkPattern :: Expr -> TokParser Pattern +checkPattern expr = do + nPlusK <- isExtensionEnabled NPlusKPatterns + liftCheck (checkPatternWith nPlusK expr) + -- | Convert an expression tree into a pattern. +-- The 'Bool' argument is 'True' when the @NPlusKPatterns@ extension is on. -- Returns @Left@ with a diagnostic message if the expression cannot be -- interpreted as a valid pattern. -checkPattern :: Expr -> Either Text Pattern -checkPattern expr = case expr of - EAnn ann sub -> fmap (PAnn ann) (checkPattern sub) +checkPatternWith :: Bool -> Expr -> Either Text Pattern +checkPatternWith nPlusK expr = case expr of + EAnn ann sub -> fmap (PAnn ann) (checkPattern' sub) EPragma pragma _ -> checkPragmaPattern pragma -- Variables and constructors EVar name @@ -45,39 +55,42 @@ -- produce @PParen (PView f pat)@ to preserve the explicit parens in -- the AST, matching the shape produced by the dedicated pattern parser. EParen inner - | Just vp <- asViewPat inner -> Right (PParen vp) - | otherwise -> PParen <$> checkPattern inner + | Just vp <- asViewPat nPlusK inner -> Right (PParen vp) + | otherwise -> PParen <$> checkPattern' inner -- Tuple ETuple fl elems | Just tupleCon <- tupleConstructorPattern fl elems -> Right tupleCon | otherwise -> do - pats <- traverse checkTupleElement elems + pats <- traverse (checkTupleElement nPlusK) elems Right (PTuple fl pats) -- List - EList elems -> PList <$> traverse checkPattern elems + EList elems -> PList <$> traverse checkPattern' elems -- Unboxed sum - EUnboxedSum i n e -> PUnboxedSum i n <$> checkPattern e + EUnboxedSum i n e -> PUnboxedSum i n <$> checkPattern' e -- View pattern: @expr -> pat@. EViewPat l r -> do - rPat <- checkPattern r + rPat <- checkPattern' r Right (PView l rPat) -- Infix: only constructor operators (starting with ':') are valid in patterns. EInfix l op r | isConLikeOp op -> do - lPat <- checkPattern l - rPat <- checkPattern r + lPat <- checkPattern' l + rPat <- checkPattern' r Right (PInfix lPat op rPat) + | nPlusK, + Just pat <- nPlusKPattern l op r -> + Right pat | otherwise -> Left ("unexpected variable operator '" <> renderName op <> "' in pattern") -- Type signature ETypeSig e ty -> do - pat <- checkPattern e + pat <- checkPattern' e Right (PTypeSig pat ty) -- Negation (must be a literal) ENegate inner -> checkNegLitPattern inner -- Application: accumulate arguments into PCon EApp f x -> do - fPat <- checkPattern f - xPat <- checkPattern x + fPat <- checkPattern' f + xPat <- checkPattern' x case peelPatternAnn fPat of PCon name typeArgs args -> Right (PCon name typeArgs (args ++ [xPat])) PBuiltinCon con typeArgs args -> Right (PBuiltinCon con typeArgs (args ++ [xPat])) @@ -87,7 +100,7 @@ patFields <- traverse ( \field -> do - pat <- checkPattern (recordFieldValue field) + pat <- checkPattern' (recordFieldValue field) pure field {recordFieldValue = pat} ) fields @@ -122,7 +135,7 @@ EGetField {} -> Left "unexpected record field access in pattern" EGetFieldProjection {} -> Left "unexpected projection section in pattern" ETypeApp fun ty -> do - funPat <- checkPattern fun + funPat <- checkPattern' fun case peelPatternAnn funPat of PCon name typeArgs args -> Right (PCon name (typeArgs ++ [ty]) args) PBuiltinCon con typeArgs args -> Right (PBuiltinCon con (typeArgs ++ [ty]) args) @@ -136,6 +149,8 @@ ETHTypeNameQuote {} -> Left "unexpected Template Haskell type name quote in pattern" ETHTypedSplice {} -> Left "unexpected typed Template Haskell splice in pattern" EProc {} -> Left "unexpected proc expression in pattern" + where + checkPattern' = checkPatternWith nPlusK checkPragmaPattern :: Pragma -> Either Text Pattern checkPragmaPattern pragma = @@ -143,14 +158,10 @@ PragmaSCC {} -> Left "unexpected SCC pragma in pattern" _ -> Left "unexpected pragma in pattern" --- | Convert a list of expressions into patterns. -checkPatterns :: [Expr] -> Either Text [Pattern] -checkPatterns = traverse checkPattern - -- | Check that a tuple element is not a tuple section (Nothing). -checkTupleElement :: Maybe Expr -> Either Text Pattern -checkTupleElement Nothing = Left "unexpected tuple section in pattern" -checkTupleElement (Just e) = checkPattern e +checkTupleElement :: Bool -> Maybe Expr -> Either Text Pattern +checkTupleElement _ Nothing = Left "unexpected tuple section in pattern" +checkTupleElement nPlusK (Just e) = checkPatternWith nPlusK e -- | A tuple section with no fields, such as @(,)@ or @(#,,#)@, is the -- prefix tuple constructor. @@ -168,6 +179,34 @@ EAnn ann sub -> fmap (PAnn ann) (checkNegLitPattern sub) _ -> Left "negation in pattern requires a numeric literal" +-- | Try to interpret @l op r@ as an n+k pattern such as @n+1@. +-- The operator must be an unqualified @+@, the left operand must be an +-- unqualified variable, and the right operand must be a plain integer literal. +nPlusKPattern :: Expr -> Name -> Expr -> Maybe Pattern +nPlusKPattern l op r + | isNothing (nameQualifier op), + nameType op == NameVarSym, + nameText op == "+", + Just var <- nPlusKVar l, + Just lit <- nPlusKLiteral r = + Just (PNPlusK var lit) + | otherwise = Nothing + where + nPlusKVar e = + case e of + EAnn _ sub -> nPlusKVar sub + EVar name + | isNothing (nameQualifier name), + nameType name == NameVarId, + nameText name /= "_" -> + Just (nameToUnqualified name) + _ -> Nothing + nPlusKLiteral e = + case e of + EAnn ann sub -> LitAnn ann <$> nPlusKLiteral sub + EInt n TInteger repr -> Just (LitInt n TInteger repr) + _ -> Nothing + -- | Check whether an operator is a constructor operator (starts with ':'). -- Constructor operators and backtick-quoted constructors are valid in patterns; -- variable operators like @+@ or @*@ are not. @@ -180,9 +219,9 @@ -- 'checkPattern' to strip the outer parentheses and produce @PView@ -- directly (matching the AST shape that the dedicated pattern parser -- produces). -asViewPat :: Expr -> Maybe Pattern -asViewPat (EViewPat l r) = - case checkPattern r of +asViewPat :: Bool -> Expr -> Maybe Pattern +asViewPat nPlusK (EViewPat l r) = + case checkPatternWith nPlusK r of Right rPat -> Just (PView l rPat) Left _ -> Nothing -asViewPat _ = Nothing +asViewPat _ _ = Nothing diff --git a/src/Aihc/Parser/Internal/Cmd.hs b/src/Aihc/Parser/Internal/Cmd.hs --- a/src/Aihc/Parser/Internal/Cmd.hs +++ b/src/Aihc/Parser/Internal/Cmd.hs @@ -176,7 +176,7 @@ expr <- exprParser hasArrow <- optionalTok TkReservedLeftArrow if hasArrow - then DoBind <$> liftCheck (checkPattern expr) <*> cmdParser + then DoBind <$> checkPattern expr <*> cmdParser else do -- No bind arrow: this is a body statement. Check for arrow tail. mArrTail <- MP.optional cmdArrTailParser 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 @@ -12,6 +12,13 @@ tokenKindDispatch, optionalTok, optionalTokThen, + discardTok, + discardLastToken, + discardIfEmpty, + discarding, + tracePosition, + discardTraceEntryAt, + sepEndByDiscard, eofTok, varIdTok, tokenSatisfy, @@ -88,12 +95,12 @@ import Aihc.Parser.Lex (LayoutState (..), LexToken (..), LexTokenKind (..), TokenOrigin (..), closeImplicitLayoutContext) import Aihc.Parser.Syntax -import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, sourcePosSpan, tokStreamExtensionSet) -import Control.Monad (guard) +import Aihc.Parser.Types (ParserErrorComponent (..), TokStream (..), Trace (..), discardLastTraceEntry, discardTraceEntriesFrom, discardTraceRange, mkFoundToken, setTokStreamLayout, setTokStreamPendingPragmas, sourcePosSpan, tokStreamExtensionSet) +import Control.Monad (guard, unless, when) import Data.Char (isUpper) import Data.Functor (($>)) import Data.List.NonEmpty qualified as NE -import Data.Maybe (catMaybes) +import Data.Maybe (isJust, maybeToList) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -240,6 +247,66 @@ else pure Nothing {-# INLINE optionalTokThen #-} +-- | Mark the token that the parser took last as discarded in the token trace. +-- Use it for a token that the AST does not keep, for example a trailing comma. +-- Two inputs with the same AST then have the same trace without the discarded +-- tokens. +discardLastToken :: TokParser () +discardLastToken = + MP.updateParserState (\s -> s {MP.stateInput = discardLastTraceEntry (MP.stateInput s)}) + +-- | Run a parser. If its result is empty, mark each token that it took as +-- discarded in the token trace. Use it for an optional clause that the AST +-- does not keep when it is empty, for example @where {}@. +discardIfEmpty :: TokParser [a] -> TokParser [a] +discardIfEmpty parser = do + start <- traceLengthNow + items <- parser + when (null items) $ + MP.updateParserState (\s -> s {MP.stateInput = discardTraceEntriesFrom start (MP.stateInput s)}) + pure items + +-- | Run a parser, and mark each token that it took as discarded in the token +-- trace. +discarding :: TokParser a -> TokParser a +discarding parser = do + start <- traceLengthNow + result <- parser + MP.updateParserState (\s -> s {MP.stateInput = discardTraceEntriesFrom start (MP.stateInput s)}) + pure result + +traceLengthNow :: TokParser Int +traceLengthNow = maybe 0 traceLength . tokStreamTrace <$> MP.getInput + +-- | The position in the token trace of the next token that the parser takes. +tracePosition :: TokParser Int +tracePosition = traceLengthNow + +-- | Mark the trace entry at a position from 'tracePosition' as discarded. +discardTraceEntryAt :: Int -> TokParser () +discardTraceEntryAt position = + MP.updateParserState (\s -> s {MP.stateInput = discardTraceRange position (position + 1) (MP.stateInput s)}) + +-- | Take a token of the given kind that the AST does not keep. +discardTok :: LexTokenKind -> TokParser () +discardTok expected = expectedTok expected *> discardLastToken + +-- | Like 'MP.sepEndBy'. The AST does not keep a trailing separator, so the +-- token trace marks it as discarded. +sepEndByDiscard :: TokParser a -> TokParser sep -> TokParser [a] +sepEndByDiscard p sep = sepEndBy1Discard p sep <|> pure [] + +sepEndBy1Discard :: TokParser a -> TokParser sep -> TokParser [a] +sepEndBy1Discard p sep = do + x <- p + rest <- MP.option [] $ do + _ <- sep + xs <- sepEndByDiscard p sep + -- An empty tail takes no token, so the separator is the newest entry. + when (null xs) discardLastToken + pure xs + pure (x : rest) + -- | Match the end-of-file token. -- -- The lexer emits a 'TkEOF' token at the end of input. This parser consumes @@ -665,7 +732,7 @@ if closed then expectedTok TkSpecialRBrace else MP.empty skipSemicolons :: TokParser () -skipSemicolons = MP.skipMany (expectedTok TkSpecialSemicolon) +skipSemicolons = MP.skipMany (discardTok TkSpecialSemicolon) bracedSemiSep :: TokParser a -> TokParser [a] bracedSemiSep = braces . layoutSemiSep @@ -681,9 +748,33 @@ plainSemiSep1 :: TokParser a -> TokParser [a] plainSemiSep1 = layoutSemiSep1 +-- | Parse items separated by semicolons. An item can be empty. +-- +-- The AST keeps only the items. Thus the token trace keeps a semicolon only +-- if an item comes before it and an item follows it directly. Each other +-- semicolon is marked as discarded. Then a list of @n@ items always keeps +-- @n - 1@ semicolons. layoutSemiSep :: TokParser a -> TokParser [a] -layoutSemiSep parser = - catMaybes <$> MP.sepBy (MP.optional parser) (expectedTok TkSpecialSemicolon) +layoutSemiSep parser = do + first <- MP.optional parser + go (isJust first) (maybeToList first) + where + go seenItem acc = do + -- 'MP.optional' adds the semicolon to the expected tokens of an error, + -- as 'MP.sepBy' did. + hasSemicolon <- isJust <$> MP.optional (expectedTok TkSpecialSemicolon) + if not hasSemicolon + then pure (reverse acc) + else do + unless seenItem discardLastToken + next <- MP.optional parser + case next of + Nothing -> do + -- An empty item takes no token, so the semicolon is the newest + -- entry. + when seenItem discardLastToken + go seenItem acc + Just item -> go True (item : acc) layoutSemiSep1 :: TokParser a -> TokParser [a] layoutSemiSep1 parser = do @@ -855,7 +946,7 @@ MP.try parenthesizedContextItemsParser <|> fmap pure (contextItemParserWith typeParser typeAtomParser) where parenthesizedContextItemsParser = withSpanAnn annotateSingleItem $ do - items <- parens (listContextItemParser `MP.sepEndBy` expectedTok TkSpecialComma) + items <- parens (listContextItemParser `sepEndByDiscard` expectedTok TkSpecialComma) guardNotFollowedByConstraintInfixOp case items of [] -> fail "empty constraint list in parens" @@ -1026,8 +1117,21 @@ rhsPat <- infixPatternParser expectedTok TkSpecialRParen tailPats <- MP.many prefixPatternParser + -- GHC reads a parenthesized infix head with no more arguments as a + -- pattern. Thus, with n+k patterns on, @(n + 1) = e@ and + -- @(n + 1 : xs) = e@ are pattern bindings, not definitions of @(+)@. + nPlusK <- isExtensionEnabled NPlusKPatterns + when (nPlusK && null tailPats && isNPlusKHead lhsPat op) $ + fail "an n+k pattern binding is not a function head" pure (MatchHeadInfix, op, [lhsPat, rhsPat] <> tailPats) + isNPlusKHead lhsPat op = + unqualifiedNameType op == NameVarSym + && unqualifiedNameText op == "+" + && case peelPatternAnn lhsPat of + PVar var -> unqualifiedNameType var == NameVarId + _ -> False + functionBinderNameParser :: TokParser UnqualifiedName functionBinderNameParser = variableIdentifierParser <|> parens variableOperatorParser @@ -1117,7 +1221,8 @@ if not hasDotDot then pure (fields, False) else do - _ <- optionalTok TkSpecialComma + hasComma <- optionalTok TkSpecialComma + when hasComma discardLastToken pure (fields, True) else pure (fields, False) @@ -1160,7 +1265,10 @@ x <- p rest <- MP.option [] $ do _ <- layoutSep sep - layoutSepEndBy p sep + xs <- layoutSepEndBy p sep + -- An empty tail takes no token, so the separator is the newest entry. + when (null xs) discardLastToken + pure xs pure (x : rest) -- | Like Megaparsec's 'MP.sepBy1' but implements the parse-error rule for 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 @@ -103,6 +103,13 @@ TkReservedDoubleColon -> sigOrValueDecl TkSpecialComma -> sigOrValueDecl TkReservedEquals -> valueDecl + TkVarSym "+" -> do + -- With n+k patterns on, @n + 1 :: Int = e@ is a typed pattern + -- binding. Other declarations here are definitions of @(+)@. + nPlusK <- isExtensionEnabled NPlusKPatterns + if nPlusK + then nonBareVarPatternBindDeclParser <|> valueDecl + else valueDecl _ | patternBindMayFollowVarId nextTokKind -> nonBareVarPatternBindDeclParser <|> valueDecl @@ -139,9 +146,22 @@ pat <- region "while parsing pattern binding" patternParser case pat of PVar {} -> fail "bare variable bindings are parsed as function declarations" + _ + | startsWithNPlusK pat -> + fail "a binding that starts with n + k without a type signature defines (+)" _ -> do DeclValue . PatternBind NoMultiplicityTag pat <$> equationRhsParser +-- | Whether a pattern starts with an n+k pattern and has no type signature. +-- GHC reads @n + 1 = e@ and @n + 1 : xs = e@ as definitions of @(+)@. +startsWithNPlusK :: Pattern -> Bool +startsWithNPlusK pat = + case pat of + PAnn _ sub -> startsWithNPlusK sub + PNPlusK {} -> True + PInfix lhs _ _ -> startsWithNPlusK lhs + _ -> False + -- | Parse a pragma declaration (e.g. {-# INLINE f #-}, {-# SPECIALIZE ... #-}) pragmaDeclParser :: TokParser Decl pragmaDeclParser = withSpanAnn (DeclAnn . mkSpanAnnotation) $ DeclPragma <$> anyPragmaParser "pragma declaration" @@ -594,7 +614,8 @@ classDefaultTypeInstParser' :: Bool -> TokParser ClassDeclItem classDefaultTypeInstParser' requireInstance = withSpanAnn (ClassItemAnn . mkSpanAnnotation) $ do expectedTok TkKeywordType - when requireInstance (expectedTok TkKeywordInstance) + -- The AST does not keep the @instance@ keyword of a default instance. + when requireInstance (discardTok TkKeywordInstance) forallBinders <- MP.option [] explicitForallParser (headForm, lhs) <- typeFamilyLhsParser expectedTok TkReservedEquals @@ -618,7 +639,8 @@ instanceTypeFamilyInstParser :: TokParser InstanceDeclItem instanceTypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkSpanAnnotation) $ do expectedTok TkKeywordType - _ <- optionalTok TkKeywordInstance + hasInstance <- optionalTok TkKeywordInstance + when hasInstance discardLastToken forallBinders <- MP.option [] explicitForallParser (headForm, lhs) <- typeFamilyLhsParser expectedTok TkReservedEquals @@ -637,7 +659,8 @@ instanceDataFamilyInstParser :: TokParser InstanceDeclItem instanceDataFamilyInstParser = withSpanAnn (InstanceItemAnn . mkSpanAnnotation) $ do expectedTok TkKeywordData - _ <- optionalTok TkKeywordInstance + hasInstance <- optionalTok TkKeywordInstance + when hasInstance discardLastToken (_, head') <- typeFamilyLhsParser kind <- familyResultKindParser (constructors, derivingClauses) <- gadtDataDeclParser <|> traditionalDataDeclParser @@ -657,7 +680,8 @@ instanceNewtypeFamilyInstParser :: TokParser InstanceDeclItem instanceNewtypeFamilyInstParser = withSpanAnn (InstanceItemAnn . mkSpanAnnotation) $ do expectedTok TkKeywordNewtype - _ <- optionalTok TkKeywordInstance + hasInstance <- optionalTok TkKeywordInstance + when hasInstance discardLastToken (_, head') <- typeFamilyLhsParser kind <- familyResultKindParser expectedTok TkReservedEquals @@ -712,7 +736,7 @@ defaultDeclParser :: TokParser Decl defaultDeclParser = withSpanAnn (DeclAnn . mkSpanAnnotation) $ do expectedTok TkKeywordDefault - DeclDefault <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma) + DeclDefault <$> parens (typeParser `sepEndByDiscard` expectedTok TkSpecialComma) -- | Report core general declaration: -- @@ -802,15 +826,17 @@ functionalDependencyDetermined = determines } +-- An empty @where@ clause is not in the AST, so its tokens are discarded. classWhereClauseParser :: TokParser [ClassDeclItem] -classWhereClauseParser = do +classWhereClauseParser = discardIfEmpty $ do expectedTok TkKeywordWhere bracedSemiSep classDeclItemParser <|> plainSemiSep1 classDeclItemParser <|> pure [] +-- An empty @where@ clause is not in the AST, so its tokens are discarded. whereClauseItemsParser :: TokParser a -> TokParser [a] -whereClauseItemsParser itemParser = do +whereClauseItemsParser itemParser = discardIfEmpty $ do expectedTok TkKeywordWhere bracedSemiSep itemParser <|> plainSemiSep1 itemParser <|> pure [] @@ -898,8 +924,9 @@ standaloneDerivingHead = derivingHead } +-- An empty @where@ clause is not in the AST, so its tokens are discarded. instanceWhereClauseParser :: TokParser [InstanceDeclItem] -instanceWhereClauseParser = do +instanceWhereClauseParser = discardIfEmpty $ do expectedTok TkKeywordWhere bracedSemiSep instanceDeclItemParser <|> plainSemiSep1 instanceDeclItemParser @@ -1358,20 +1385,27 @@ rhs <- declTypeParamParser pure (InfixBinderHead lhs op rhs []) + -- The AST keeps these parentheses only when more parameters follow. parenthesizedInfixDeclHeadParser = do + openPosition <- tracePosition expectedTok TkSpecialLParen lhs <- declTypeParamParser op <- opParser rhs <- declTypeParamParser + closePosition <- tracePosition expectedTok TkSpecialRParen tailParams <- MP.many declTypeParamParser + when (null tailParams) $ do + discardTraceEntryAt openPosition + discardTraceEntryAt closePosition pure (InfixBinderHead lhs op rhs tailParams) + -- The AST does not keep these parentheses. parenthesizedPrefixDeclHeadParser = do - expectedTok TkSpecialLParen + discardTok TkSpecialLParen name <- constructorUnqualifiedNameParser params <- MP.some declTypeParamParser - expectedTok TkSpecialRParen + discardTok TkSpecialRParen tailParams <- MP.many declTypeParamParser pure (PrefixBinderHead name (params <> tailParams)) @@ -1513,7 +1547,7 @@ _ -> pure (DerivingClause (viaStrategy <|> strategy) classes) where singleClass = Left <$> constructorNameParser - parenClasses = Right <$> parens (typeParser `MP.sepEndBy` expectedTok TkSpecialComma) + parenClasses = Right <$> parens (typeParser `sepEndByDiscard` expectedTok TkSpecialComma) derivingViaTypeParser :: TokParser Type derivingViaTypeParser = do @@ -1603,7 +1637,7 @@ pure name recordFieldsParser :: TokParser [FieldDecl] -recordFieldsParser = braces (recordFieldDeclParser `MP.sepEndBy` expectedTok TkSpecialComma) +recordFieldsParser = braces (recordFieldDeclParser `sepEndByDiscard` expectedTok TkSpecialComma) recordFieldDeclParser :: TokParser FieldDecl recordFieldDeclParser = withSpan $ do @@ -1766,7 +1800,7 @@ -- | Parse the record fields of a pattern synonym: @{field1, field2, ...}@ patSynRecordFieldsParser :: TokParser [Text] -patSynRecordFieldsParser = braces (lowerIdentifierParser `MP.sepEndBy` expectedTok TkSpecialComma) +patSynRecordFieldsParser = braces (lowerIdentifierParser `sepEndByDiscard` expectedTok TkSpecialComma) -- | Parse the direction marker and RHS pattern of a pattern synonym. patSynDirAndPatParser :: UnqualifiedName -> TokParser (PatSynDir, Pattern) 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 @@ -17,7 +17,7 @@ import Aihc.Parser.Internal.Cmd (cmdParser) import Aihc.Parser.Internal.Common import Aihc.Parser.Internal.Decl (declParser, fixityDeclParser, pragmaDeclParser) -import Aihc.Parser.Internal.Pattern (apatParser, caseAltPatternParser, patParser, patternParser) +import Aihc.Parser.Internal.Pattern (apatParser, caseAltPatternParser, nPlusKOrPatParser, patParser, patternParser) import Aihc.Parser.Internal.Type (typeAtomParser, typeParser, typeSignatureParser) import Aihc.Parser.Lex (LexToken (..), LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax @@ -61,7 +61,7 @@ _ -> pure () hasArrow <- optionalTok TkReservedLeftArrow if hasArrow - then Left <$> liftCheck (checkPattern expr) + then Left <$> checkPattern expr else pure (Right expr) patternBind = do @@ -1433,7 +1433,7 @@ thTypeQuoteParser = thQuoteParser (EAnn . mkSpanAnnotation) TkTHTypeQuoteOpen TkTHExpQuoteClose typeParser ETHTypeQuote thPatQuoteParser :: TokParser Expr -thPatQuoteParser = thQuoteParser (EAnn . mkSpanAnnotation) TkTHPatQuoteOpen TkTHExpQuoteClose patParser ETHPatQuote +thPatQuoteParser = thQuoteParser (EAnn . mkSpanAnnotation) TkTHPatQuoteOpen TkTHExpQuoteClose nPlusKOrPatParser ETHPatQuote thUntypedSpliceParser :: TokParser Expr thUntypedSpliceParser = withSpanAnn (EAnn . mkSpanAnnotation) $ do diff --git a/src/Aihc/Parser/Internal/Import.hs b/src/Aihc/Parser/Internal/Import.hs --- a/src/Aihc/Parser/Internal/Import.hs +++ b/src/Aihc/Parser/Internal/Import.hs @@ -51,7 +51,7 @@ _ -> Nothing exportSpecListParser :: TokParser [ExportSpec] -exportSpecListParser = parens $ exportSpecParser `MP.sepEndBy` expectedTok TkSpecialComma +exportSpecListParser = parens $ exportSpecParser `sepEndByDiscard` expectedTok TkSpecialComma exportSpecParser :: TokParser ExportSpec exportSpecParser = withSpanAnn (ExportAnn . mkSpanAnnotation) $ do @@ -102,6 +102,8 @@ False -> pure MembersAll True -> do trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma + -- With no member after it, the comma is not in the AST. + when (null trailingMembers) discardLastToken pure (MembersListAll 0 trailingMembers) parseMemberList = do @@ -122,6 +124,8 @@ False -> pure (MembersListAll (length members) members) True -> do trailingMembers <- memberNameParser `MP.sepBy` expectedTok TkSpecialComma + -- With no member after it, the comma is not in the AST. + when (null trailingMembers) discardLastToken pure (MembersListAll (length members) (members <> trailingMembers)) memberNameParser = do @@ -192,7 +196,7 @@ importSpecParser = withSpan $ do isHiding <- MP.option False (expectedTok TkVarHiding >> pure True) - items <- parens $ importItemParser `MP.sepEndBy` expectedTok TkSpecialComma + items <- parens $ importItemParser `sepEndByDiscard` expectedTok TkSpecialComma pure $ \span' -> ImportSpec { importSpecAnns = [mkSpanAnnotation span'], diff --git a/src/Aihc/Parser/Internal/Module.hs b/src/Aihc/Parser/Internal/Module.hs --- a/src/Aihc/Parser/Internal/Module.hs +++ b/src/Aihc/Parser/Internal/Module.hs @@ -24,7 +24,9 @@ import Aihc.Parser.Internal.Import (importDeclParser, languagePragmaParser, moduleHeaderParser) import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind) import Aihc.Parser.Syntax (Decl, ImportDecl, Module (..), mkSpanAnnotation) -import Control.Monad (void) +import Aihc.Parser.Types (TokStream (..)) +import Control.Monad (void, when) +import Data.Maybe (isJust) import Text.Megaparsec qualified as MP data RecoverParseStep a @@ -40,8 +42,8 @@ let !startInput = MP.stateInput startState !startOffset = MP.stateOffset startState !inputStart = MP.pstateSourcePos (MP.statePosState startState) - languagePragmas <- MP.many (languagePragmaParser <* MP.many (expectedTok TkSpecialSemicolon)) - mHeader <- MP.optional (moduleHeaderParser <* MP.many (expectedTok TkSpecialSemicolon)) + languagePragmas <- MP.many (languagePragmaParser <* skipSemicolons) + mHeader <- MP.optional (moduleHeaderParser <* skipSemicolons) expectedTok TkSpecialLBrace imports <- importDeclsWithRecovery (decls, finalState) <- @@ -52,6 +54,11 @@ <* MP.lookAhead eofTok ) MP.updateParserState (\state -> state {MP.stateParseErrors = MP.stateParseErrors finalState}) + -- The declarations were parsed in a separate run. With a token trace, take + -- the stream from the end of that run, so the trace has their tokens. This + -- forces the declarations, so only a traced parse does it. + when (isJust (tokStreamTrace startInput)) $ + MP.updateParserState (\state -> state {MP.stateInput = MP.stateInput finalState}) let moduleSpan = consumedSpan inputStart startInput startOffset (MP.stateInput finalState) (MP.stateOffset finalState) pure Module 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 @@ -4,6 +4,7 @@ ( patternParser, patternParserWithTypeSigParser, caseAltPatternParser, + nPlusKOrPatParser, patParser, lpatParser, apatParser, @@ -34,7 +35,7 @@ optionalSuffix (expectedTok TkReservedDoubleColon *> typeSigParser) PTypeSig - patParser + nPlusKOrPatParser -- | Parse the pattern position of a case alternative. -- @@ -46,8 +47,56 @@ -- | Case alternatives intentionally use the report @pat@ level rather than -- the outer typed-pattern wrapper. caseAltPatternParser :: TokParser Pattern -caseAltPatternParser = patParser +caseAltPatternParser = nPlusKOrPatParser +-- | Parse an n+k pattern or a @pat@. +-- +-- Haskell 98 puts the n+k pattern at the top pattern level: +-- +-- @ +-- pat → var + integer +-- | pat0 +-- @ +-- +-- Only accept the n+k form when the @NPlusKPatterns@ extension is on. +-- Function heads do not use this parser. In a function head, @n + 1 = e@ +-- is a definition of @(+)@, not a pattern binding. +-- +-- Like GHC, accept an n+k pattern as the left operand of an infix +-- constructor pattern, as in @n + 1 : xs@. +nPlusKOrPatParser :: TokParser Pattern +nPlusKOrPatParser = do + enabled <- isExtensionEnabled NPlusKPatterns + isNPlusK <- if enabled then startsNPlusKPattern else pure False + if isNPlusK + then do + lhs <- nPlusKPatternParser + rest <- MP.many ((,) <$> conOperatorParser <*> lpatParser) + pure (foldInfixL buildInfixPattern lhs rest) + else patParser + +-- | Look at the next three tokens for @var + integer@. +startsNPlusKPattern :: TokParser Bool +startsNPlusKPattern = do + tokens <- MP.optional . MP.try . lookAhead $ (,,) <$> anySingle <*> anySingle <*> anySingle + pure $ + case tokens of + Just (varTok, plusTok, intTok) -> + case (lexTokenKind varTok, lexTokenKind plusTok, lexTokenKind intTok) of + (TkVarId {}, TkVarSym "+", TkInteger _ TInteger) -> True + _ -> False + Nothing -> False + +nPlusKPatternParser :: TokParser Pattern +nPlusKPatternParser = withSpanAnn (PAnn . mkSpanAnnotation) $ do + name <- + tokenSatisfy "variable" $ \tok -> + case lexTokenKind tok of + TkVarId ident -> Just (mkUnqualifiedNameAt tok NameVarId ident) + _ -> Nothing + expectedTok (TkVarSym "+") + PNPlusK name <$> intLiteralParser + -- | Parse a pattern (@pat@ in the Haskell Report). -- -- @ @@ -323,7 +372,7 @@ -- | Parse the contents of record pattern braces, supporting RecordWildCards ".." recordPatternFieldListParser :: TokParser ([RecordField Pattern], Bool) recordPatternFieldListParser = - recordFieldsWithWildcardsParser (recordFieldPatternParser `MP.sepEndBy` expectedTok TkSpecialComma) + recordFieldsWithWildcardsParser (recordFieldPatternParser `sepEndByDiscard` expectedTok TkSpecialComma) listPatternParser :: TokParser Pattern listPatternParser = withSpanAnn (PAnn . mkSpanAnnotation) $ do @@ -355,12 +404,12 @@ tok <- peekToken case lexTokenKind tok of TkReservedRightArrow -> pure (Left expr) - TkSpecialComma -> Right <$> liftCheck (checkPattern expr) - TkSpecialRBracket -> Right <$> liftCheck (checkPattern expr) - TkSpecialRBrace -> Right <$> liftCheck (checkPattern expr) - TkSpecialRParen -> Right <$> liftCheck (checkPattern expr) - TkSpecialUnboxedRParen -> Right <$> liftCheck (checkPattern expr) - TkReservedPipe -> Right <$> liftCheck (checkPattern expr) + TkSpecialComma -> Right <$> checkPattern expr + TkSpecialRBracket -> Right <$> checkPattern expr + TkSpecialRBrace -> Right <$> checkPattern expr + TkSpecialRParen -> Right <$> checkPattern expr + TkSpecialUnboxedRParen -> Right <$> checkPattern expr + TkReservedPipe -> Right <$> checkPattern expr _ -> fail "incomplete element parse" case mResult of Just (Left expr) -> do 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 @@ -21,6 +21,7 @@ import {-# SOURCE #-} Aihc.Parser.Internal.Expr (exprParser) import Aihc.Parser.Lex (LexTokenKind (..), lexTokenKind, lexTokenSpan, lexTokenText) import Aihc.Parser.Syntax +import Control.Monad (when) import Data.Char (isLower) import Data.Functor (($>), (<&>)) import Data.Text qualified as T @@ -199,10 +200,17 @@ -- from @a % 1 -> b@ (type operator applied to @a@ and @1@, then unrestricted arrow). multiplicityAnnotatedArrowParser :: TokParser ArrowKind multiplicityAnnotatedArrowParser = do + start <- tracePosition expectedTok TkPrefixPercent mult <- typeAtomParser + arrowPosition <- tracePosition expectedTok TkReservedRightArrow - pure (multiplicityToArrowKind mult) + let arrowKind = multiplicityToArrowKind mult + -- The AST does not tell @%1 ->@ from @⊸@. Keep only the arrow in the + -- token trace, so both spellings give the same trace. + when (arrowKind == ArrowLinear) $ + mapM_ discardTraceEntryAt [start .. arrowPosition - 1] + pure arrowKind multiplicityToArrowKind :: Type -> ArrowKind multiplicityToArrowKind ty = 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 @@ -665,7 +665,10 @@ wrapPat (typedPatternBindLhsNeedsParens inner) (PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty)) - _ -> addPatternParens pat + -- A bare @n + 1 = e@ defines @(+)@. Keep the parentheses so that the + -- declaration stays a pattern binding. With a type signature, as in + -- @n + 1 :: Int = e@, the declaration is always a pattern binding. + _ -> wrapLeadingNPlusK (addPatternParens pat) typedPatternBindLhsNeedsParens :: Pattern -> Bool typedPatternBindLhsNeedsParens (PAnn _ sub) = typedPatternBindLhsNeedsParens sub @@ -1399,6 +1402,13 @@ -- following @by@ or @using@ keyword. Parenthesizing it is not only -- unnecessary: GHC preserves the grouping in its parsed fingerprint. EIf {} -> False + -- With TransformListComp, @by@ and @using@ are keywords. The keyword + -- closes the implicit layout block of the case alternatives, so a case + -- expression needs no parentheses here. + ECase {} -> False + -- A multi-way if also opens an implicit layout block, and the keyword + -- closes it. + EMultiWayIf {} -> False ETypeSig {} -> True EParen {} -> False EInfix _ _ rhs -> needsCompTransformInfixRhsParens rhs @@ -1737,12 +1747,25 @@ PStrict inner -> PStrict (addApatParens inner) PIrrefutable inner -> PIrrefutable (addApatParens inner) PNegLit lit -> PNegLit lit + PNPlusK name lit -> PNPlusK name lit PParen inner -> PParen (addPatternInDelimited inner) PRecord con fields hasWildcard -> PRecord con [field {recordFieldValue = addPatternInRecordField (recordFieldValue field)} | field <- fields] hasWildcard PTypeSig inner ty -> PTypeSig (addPatternInfixOperandParens inner) (addSignatureTypeParens ty) PSplice body -> PSplice (addSpliceBodyParens body) +-- | Put parens around an n+k pattern at the start of a pattern. +-- An n+k pattern can be the left operand of an infix pattern, as in +-- @n + 1 : xs@. At the start of a declaration, @n + 1@ starts a +-- definition of @(+)@, so the n+k pattern needs parens there. +wrapLeadingNPlusK :: Pattern -> Pattern +wrapLeadingNPlusK pat = + case pat of + PAnn ann sub -> PAnn ann (wrapLeadingNPlusK sub) + PNPlusK {} -> wrapPat True pat + PInfix lhs op rhs -> PInfix (wrapLeadingNPlusK lhs) op rhs + _ -> pat + -- | Add parens for a pattern inside a delimited context (tuples, lists, etc.). -- View patterns don't need extra parens there. addPatternInDelimited :: Pattern -> Pattern @@ -1932,6 +1955,9 @@ PLit {} -> addPatternParens pat PQuasiQuote {} -> addPatternParens pat PNegLit {} -> wrapPat True (addPatternParens pat) + -- An n+k pattern is a top-level pattern form, so each atom position + -- needs parentheses. + PNPlusK {} -> wrapPat True (addPatternParens pat) PList {} -> addPatternParens pat PTuple {} -> addPatternParens pat PUnboxedSum {} -> addPatternParens pat @@ -1957,6 +1983,9 @@ case pat of PAnn ann sub -> PAnn ann (addPatternInfixOperandParens sub) PNegLit _ -> addPatternParens pat + -- The left operand of an infix pattern can be an n+k pattern, as in + -- @n + 1 : xs@. + PNPlusK {} -> addPatternParens pat PCon {} -> addPatternParens pat PBuiltinCon {} -> addPatternParens pat PInfix {} -> addPatternParens pat @@ -1983,6 +2012,7 @@ addArrowBndrPatternParens :: Pattern -> Pattern addArrowBndrPatternParens p@(PTypeSig {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PNegLit {}) = wrapPat True (addPatternParens p) +addArrowBndrPatternParens p@(PNPlusK {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PInfix {}) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PCon _ (_ : _) _) = wrapPat True (addPatternParens p) addArrowBndrPatternParens p@(PCon _ [] (_ : _)) = wrapPat True (addPatternParens p) @@ -2018,9 +2048,11 @@ -- Infix function heads use infix-pattern operand grammar, where negative -- literal patterns do not require apat parentheses. PNegLit {} -> addPatternParens pat + -- In a function head, @n + 1 `op` x@ does not parse as an n+k operand. + PNPlusK {} -> wrapPat True (addPatternParens pat) PAs {} -> addPatternParens pat PTypeSig {} -> wrapPat True (addPatternParens pat) - PInfix {} -> addPatternParens pat + PInfix {} -> wrapLeadingNPlusK (addPatternParens pat) _ -> addPatternParens pat -- | Add parens for the inner pattern of @, !, ~. 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 @@ -40,15 +40,22 @@ align, braces, brackets, + column, comma, + concatWith, + flatAlt, + group, hang, hardline, hsep, + line, + line', nest, nesting, parens, punctuate, semi, + softline, vsep, (<+>), ) @@ -61,6 +68,31 @@ -- >>> import Prettyprinter.Render.String (renderString) -- >>> let renderDoc = renderString . layoutPretty defaultLayoutOptions +-- __Line breaks.__ A construct that can fit on one line uses 'group' with +-- soft breaks ('line', 'line'', or 'spacedLine'). If the construct does not +-- fit, each soft break becomes a line break. Layout blocks ('do', 'case', +-- 'let', 'where', guards, and declaration lists) use 'hardline' and +-- 'hardVsep'. A 'group' that contains a hard line break does not become flat. +-- Thus a layout block always stops the enclosing groups from becoming flat, +-- and text that follows a block cannot move into the block. + +-- | Put each document on a new line. Unlike 'vsep', the breaks stay line +-- breaks in a 'group'. Use this for layout blocks. +hardVsep :: [Doc ann] -> Doc ann +hardVsep = concatWith (\x y -> x <> hardline <> y) + +-- | A soft break that keeps one space before the next token when it breaks. +-- In a flat 'group', it is one space. +spacedLine :: Doc ann +spacedLine = flatAlt (hardline <> " ") " " + +-- | An empty document that stops each enclosing 'group' from becoming flat. +-- Use it at the end of a layout block that has no closing token, for example +-- a multi-way @if@. Text on the same line after such a block goes into the +-- block, so the enclosing construct must break the line. +noFlat :: Doc ann +noFlat = flatAlt mempty hardline + -- | Wrap a document in braces with interior spaces: @{ content }@. -- Unlike 'braces' which produces @{content}@, this version avoids the -- @{-@ block-comment ambiguity that occurs when the content starts with a @@ -70,9 +102,15 @@ prettyRawText :: Text -> Doc ann prettyRawText raw - | T.isInfixOf "\n" raw = nesting $ \level -> nest (negate level) (pretty raw) + | T.isInfixOf "\n" raw = nesting $ \level -> nest (negate level) (prettyHardLines raw) | otherwise = pretty raw +-- | Print text that can contain newlines. Each newline stays a line break in +-- a 'group'. The 'Pretty' instance for 'Text' uses 'line', which a flat +-- 'group' changes to a space. +prettyHardLines :: Text -> Doc ann +prettyHardLines = hardVsep . map pretty . T.splitOn "\n" + prettySpliceBody :: Expr -> Doc ann prettySpliceBody = prettyExpr @@ -90,7 +128,7 @@ -- | Pretty instance for Decl - renders to valid Haskell source code. instance Pretty Decl where - pretty decl = vsep (prettyDeclLines (addDeclParens decl)) + pretty decl = hardVsep (prettyDeclLines (addDeclParens decl)) -- | Pretty instance for Type - renders to valid Haskell source code. instance Pretty Type where @@ -104,7 +142,7 @@ prettyModuleDoc :: Module -> Doc ann prettyModuleDoc modu = - vsep (pragmaLines <> headerLines <> importLines <> declLines) + hardVsep (pragmaLines <> headerLines <> importLines <> declLines) where pragmaLines = map @@ -126,7 +164,7 @@ prettyExportSpecList :: [ExportSpec] -> Doc ann prettyExportSpecList specs = - parens (hsep (punctuate comma (map prettyExportSpec specs))) + parens (prettyCommaFill (map prettyExportSpec specs)) prettyExportSpec :: ExportSpec -> Doc ann prettyExportSpec spec = @@ -193,7 +231,7 @@ prettyImportSpec spec = hsep ( ["hiding" | importSpecHiding spec] - <> [parens (hsep (punctuate comma (map prettyImportItem (importSpecItems spec))))] + <> [parens (prettyCommaFill (map prettyImportItem (importSpecItems spec)))] ) prettyImportItem :: ImportItem -> Doc ann @@ -392,7 +430,7 @@ prettyPatSynWhere _ PatSynUnidirectional = [] prettyPatSynWhere _ (PatSynExplicitBidirectional []) = ["where", spacedBraces mempty] prettyPatSynWhere name (PatSynExplicitBidirectional matches) = - ["where" <> nest 2 (hardline <> vsep (map (prettyFunctionMatch name) matches))] + ["where" <> nest 2 (hardline <> hardVsep (map (prettyFunctionMatch name) matches))] prettyFunctionMatchLines :: UnqualifiedName -> Match -> [Doc ann] prettyFunctionMatchLines name match = @@ -403,7 +441,7 @@ <> nest 2 ( hardline - <> vsep + <> hardVsep ( map prettyGuardedRhsBlock grhss <> [prettyWhereClauseBare mWhereDecls | isJust mWhereDecls] ) @@ -443,7 +481,7 @@ prettyWhereClauseBare Nothing = mempty prettyWhereClauseBare (Just []) = "where" <+> spacedBraces mempty prettyWhereClauseBare (Just decls) = - "where" <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls)) + "where" <> nest 2 (hardline <> hardVsep (concatMap prettyDeclLines decls)) prettyIndentedWhereClause :: Maybe [Decl] -> Doc ann prettyIndentedWhereClause Nothing = mempty @@ -453,7 +491,7 @@ prettyTHDeclQuote [] = "[d| |]" prettyTHDeclQuote decls = "[d|" - <> nest 2 (hardline <> vsep (concatMap prettyDeclLines decls)) + <> nest 2 (hardline <> hardVsep (concatMap prettyDeclLines decls)) <+> "|]" -- | Infix type-family heads use @l \`Op\` r@ with a 'NameConId' operator (e.g. @@ -521,7 +559,9 @@ TTypeApp f x -> prettyType f <+> prettyTypeAppArg x TFun arrowKind a b -> - prettyType a <+> prettyArrowKind arrowKind <+> prettyType b + -- When the arrows do not fit, each argument after the first starts a + -- new line with its arrow. + group (prettyType a <> nest 2 (prettyArrowTail arrowKind b)) TTuple tupleFlavor promoted elems -> let elemsDoc = hsep (punctuate comma (map prettyType elems)) tupleDoc = prettyTupleBody tupleFlavor elemsDoc @@ -543,10 +583,33 @@ TContext constraints inner -> case constraints of [] -> prettyType inner - cs -> prettyContext cs <+> "=>" <+> prettyType inner + cs -> withContext cs (prettyType inner) TSplice body -> "$" <> prettySpliceBody body TWildcard -> "_" +-- | The arrows and arguments of a function type after its first argument. +prettyArrowTail :: ArrowKind -> Type -> Doc ann +prettyArrowTail arrowKind ty = + line + <> prettyArrowKind arrowKind + <+> case ty of + TAnn _ sub -> continue sub + _ -> continue ty + where + continue t = + case t of + TFun nextKind a b -> prettyType a <> prettyArrowTail nextKind b + TAnn _ sub -> continue sub + _ -> prettyType t + +-- | A context and the item that it applies to. When they do not fit, the +-- item starts a new line after the @=>@. +withContext :: [Type] -> Doc ann -> Doc ann +withContext constraints doc = + case constraints of + [] -> doc + _ -> group (prettyContext constraints <> nest 2 (line <> "=>" <+> doc)) + prettyArrowKind :: ArrowKind -> Doc ann prettyArrowKind ArrowUnrestricted = "->" prettyArrowKind ArrowLinear = "%1" <+> "->" @@ -607,11 +670,12 @@ hsep ([prettyBuiltinCon con] <> map prettyInvisibleTypeArg typeArgs <> map prettyPattern args) PInfix lhs op rhs -> prettyPattern lhs <+> prettyNameInfixOp op <+> prettyPattern rhs PView viewExpr inner -> - prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyPattern inner) + group (prettyExpr viewExpr <> nest 1 (line <> "->" <+> prettyPattern inner)) PAs name inner -> prettyBinderUName name <> "@" <> prettyPattern inner PStrict inner -> "!" <> prettyPattern inner PIrrefutable inner -> "~" <> prettyPattern inner PNegLit lit -> "-" <> prettyLiteral lit + PNPlusK name lit -> prettyBinderUName name <+> "+" <+> prettyLiteral lit PParen inner -> parens (prettyPattern inner) PRecord con fields hasWildcard -> prettyPrefixName con @@ -652,7 +716,7 @@ | any isGadtCon ctors -> headDoc <+> prettyGadtConBlock ctors (dataDeclDeriving decl) _ -> - hsep (headParts <> ctorPart <> derivingParts (dataDeclDeriving decl)) + prettyDataBody headDoc (dataDeclConstructors decl) (dataDeclDeriving decl) where headParts = ["data"] @@ -661,17 +725,27 @@ <> kindPart headDoc = hsep headParts kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl) - ctorPart = - case dataDeclConstructors decl of - [] -> [] - ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))] +-- | The constructors and deriving clauses after a data declaration head. When +-- they do not fit, each constructor and each deriving clause starts a new +-- line. +prettyDataBody :: Doc ann -> [DataConDecl] -> [DerivingClause] -> Doc ann +prettyDataBody headDoc ctors derivingClauses = + group (headDoc <> nest 2 (ctorDocs <> derivingDocs)) + where + ctorDocs = + mconcat + [ line <> separator <+> prettyDataCon ctor + | (separator, ctor) <- zip ("=" : repeat "|") ctors + ] + derivingDocs = mconcat [line <> hsep (derivingPart clause) | clause <- derivingClauses] + prettyTypeDataDecl :: DataDecl -> Doc ann prettyTypeDataDecl decl = case dataDeclConstructors decl of ctors | any isGadtCon ctors -> headDoc <+> prettyGadtConBlock ctors [] - _ -> hsep (headParts <> ctorPart) + _ -> prettyDataBody headDoc (dataDeclConstructors decl) [] where headParts = ["type data"] @@ -679,10 +753,6 @@ <> kindPart headDoc = hsep headParts kindPart = maybe [] (\k -> ["::", prettyType k]) (dataDeclKind decl) - ctorPart = - case dataDeclConstructors decl of - [] -> [] - ctors -> ["=", hsep (punctuate " |" (map prettyDataCon ctors))] isGadtCon :: DataConDecl -> Bool isGadtCon (DataConAnn _ inner) = isGadtCon inner @@ -696,7 +766,7 @@ | isGadtCon ctor -> headDoc <+> prettyGadtConBlock [ctor] (newtypeDeclDeriving decl) _ -> - hsep (headParts <> ctorPart <> derivingParts (newtypeDeclDeriving decl)) + prettyDataBody headDoc (maybe [] pure (newtypeDeclConstructor decl)) (newtypeDeclDeriving decl) where headParts = ["newtype"] @@ -705,10 +775,6 @@ <> kindPart headDoc = hsep headParts kindPart = maybe [] (\k -> ["::", prettyType k]) (newtypeDeclKind decl) - ctorPart = - case newtypeDeclConstructor decl of - Nothing -> [] - Just ctor -> ["=", prettyDataCon ctor] derivingParts :: [DerivingClause] -> [Doc ann] derivingParts = concatMap derivingPart @@ -716,7 +782,7 @@ prettyGadtConBlock :: [DataConDecl] -> [DerivingClause] -> Doc ann prettyGadtConBlock ctors derivingClauses = "where" - <> nest 2 (hardline <> vsep (map prettyDataCon ctors <> derivingParts derivingClauses)) + <> nest 2 (hardline <> hardVsep (map prettyDataCon ctors <> derivingParts derivingClauses)) derivingPart :: DerivingClause -> [Doc ann] derivingPart (DerivingClause strategy classes) = @@ -848,26 +914,31 @@ GadtPrefixBody args resultTy -> case args of [] -> prettyType resultTy - _ -> - hsep $ - concatMap (\(bt, ak) -> [prettyBangType bt, prettyArrowKind ak]) args - ++ [prettyType resultTy] + (firstArg, firstKind) : rest -> + group + ( prettyBangType firstArg + <> nest + 2 + ( mconcat + [ line <> prettyArrowKind kind <+> doc + | (kind, doc) <- zip (firstKind : map snd rest) (map (prettyBangType . fst) rest <> [prettyType resultTy]) + ] + ) + ) GadtRecordBody fields resultTy -> braces (prettyRecordFields fields) <+> "->" <+> prettyType resultTy prettyRecordFields :: [FieldDecl] -> Doc ann prettyRecordFields fields = - hsep - ( punctuate - comma - [ hsep $ - [hsep (punctuate comma (map prettyFieldName (fieldNames fld)))] - <> maybe [] (\mult -> ["%" <> prettyType mult]) (fieldMultiplicity fld) - <> [ "::", - prettyRecordFieldBangType (fieldType fld) - ] - | fld <- fields - ] + prettyCommaBlock + ( [ hsep $ + [hsep (punctuate comma (map prettyFieldName (fieldNames fld)))] + <> maybe [] (\mult -> ["%" <> prettyType mult]) (fieldMultiplicity fld) + <> [ "::", + prettyRecordFieldBangType (fieldType fld) + ] + | fld <- fields + ] ) where prettyFieldName :: UnqualifiedName -> Doc ann @@ -898,18 +969,17 @@ prettyClassDecl :: ClassDecl -> Doc ann prettyClassDecl decl = let headDoc = - hsep - ( ["class"] - <> maybeContextPrefix (classDeclContext decl) - <> prettyNamedBinderHead (classDeclHead decl) - <> prettyClassFundeps (classDeclFundeps decl) - ) + let classHead = hsep (prettyNamedBinderHead (classDeclHead decl) <> prettyClassFundeps (classDeclFundeps decl)) + in "class" + <+> case classDeclContext decl of + Nothing -> classHead + Just constraints -> group (prettyContext constraints <> nest 2 (line <> "=>" <+> classHead)) in case classDeclItems decl of [] -> headDoc items -> headDoc <+> "where" - <> nest 2 (hardline <> vsep (concatMap prettyClassItemLines items)) + <> nest 2 (hardline <> hardVsep (concatMap prettyClassItemLines items)) prettyClassFundeps :: [FunctionalDependency] -> [Doc ann] prettyClassFundeps deps = @@ -933,12 +1003,6 @@ hsep (map pretty (typeFamilyInjectivityDetermined injectivity)) ] -maybeContextPrefix :: Maybe [Type] -> [Doc ann] -maybeContextPrefix maybeConstraints = - case maybeConstraints of - Nothing -> [] - Just constraints -> [prettyContext constraints, "=>"] - prettyClassItem :: ClassDeclItem -> Doc ann prettyClassItem item = case item of @@ -973,15 +1037,14 @@ <> map prettyPragma (instanceDeclPragmas decl) <> maybe [] (\w -> [prettyPragma w]) (instanceDeclWarning decl) <> forallTyVarBinderPrefix (instanceDeclForall decl) - <> contextPrefix (instanceDeclContext decl) - <> [prettyType (instanceDeclHead decl)] + <> [withContext (instanceDeclContext decl) (prettyType (instanceDeclHead decl))] ) in case instanceDeclItems decl of [] -> headDoc items -> headDoc <+> "where" - <> nest 2 (hardline <> vsep (concatMap prettyInstanceItemLines items)) + <> nest 2 (hardline <> hardVsep (concatMap prettyInstanceItemLines items)) prettyStandaloneDeriving :: StandaloneDerivingDecl -> Doc ann prettyStandaloneDeriving decl = @@ -998,7 +1061,7 @@ prettyPragma :: Pragma -> Doc ann prettyPragma pragma - | not (T.null (pragmaRawText pragma)) = pretty (pragmaRawText pragma) + | not (T.null (pragmaRawText pragma)) = prettyHardLines (pragmaRawText pragma) | otherwise = prettyPragmaType (pragmaType pragma) prettyPragmaType :: PragmaType -> Doc ann @@ -1020,7 +1083,7 @@ NoUnpackPragma -> "{-# NOUNPACK #-}" PragmaSource sourceText _ -> "{-# SOURCE " <> pretty sourceText <> " #-}" PragmaSCC label -> "{-# SCC " <> pretty label <> " #-}" - PragmaUnknown text -> pretty text + PragmaUnknown text -> prettyHardLines text prettyDerivingStrategy :: DerivingStrategy -> Doc ann prettyDerivingStrategy strategy = @@ -1199,13 +1262,13 @@ -- nodes in the correct positions (inserted by 'addExprParens'). -- -- >>> let expr = EApp (EVar "f") (EParen (EInfix (EVar "x") "+" (EVar "y"))) in (renderDoc (prettyExpr expr), show (shorthand expr)) --- ("f\n (x\n + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))") +-- ("f (x + y)","EApp (EVar \"f\") (EParen (EInfix (EVar \"x\") \"+\" (EVar \"y\")))") prettyExpr :: Expr -> Doc ann prettyExpr expr = case expr of EApp {} -> prettyApp expr ETypeApp fn ty -> - nest 2 (prettyExpr fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty) + group (nest 2 (prettyExpr fn) <> nest 1 (spacedLine <> prettyTypeAppArg ty)) EVar name -> prettyName name EImplicitParam name -> pretty name ETypeSyntax TypeSyntaxExplicitNamespace ty -> "type" <+> prettyType ty @@ -1228,9 +1291,9 @@ ETHSplice body -> "$" <> prettySpliceBody body ETHTypedSplice body -> "$$" <> prettySpliceBody body EIf cond yes no -> - "if" <+> prettyExpr cond <+> "then" <+> prettyExpr yes <+> "else" <+> prettyExpr no + group ("if" <+> prettyExpr cond <> nest 2 (line <> "then" <+> prettyExpr yes <> line <> "else" <+> prettyExpr no)) EMultiWayIf rhss -> - "if" <+> align (prettyMultiWayIfRhss rhss) + "if" <> prettyMultiWayIfBlock (prettyMultiWayIfRhss rhss) <> noFlat ELambdaPats pats body -> "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyExpr body ELambdaCase alts -> @@ -1238,17 +1301,17 @@ ELambdaCases alts -> "\\" <> "cases" <> prettyCaseLayout (map prettyLambdaCaseAlt alts) EInfix lhs op rhs -> - nest 2 (prettyExpr lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs) + group (nest 2 (prettyExpr lhs) <> nest 1 (line <> prettyNameInfixOp op <+> prettyExpr rhs)) EViewPat viewExpr rhs -> - prettyExpr viewExpr <> nest 1 (hardline <> "->" <+> prettyExpr rhs) + group (prettyExpr viewExpr <> nest 1 (line <> "->" <+> prettyExpr rhs)) ENegate inner -> "-" <+> prettyExprAtStatementStart inner ESectionL lhs op -> - nest 2 (prettyExpr lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op) + group (nest 2 (prettyExpr lhs) <> nest 1 (spacedLine <> prettyNameInfixOp op)) ESectionR op rhs -> prettyNameInfixOp op <+> prettyExpr rhs ELetDecls decls body -> case decls of [] -> prettyLetDecls decls <+> "in" <+> prettyExpr body - _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyExpr body)) + _ -> group (align (prettyLetDecls decls <> nest 2 (line <> "in" <+> prettyExpr body))) ECase scrutinee alts -> prettyCaseExpr prettyCaseLayout scrutinee alts EDo stmts flavor -> @@ -1256,28 +1319,28 @@ EListComp body quals -> brackets ( let qualifiers = prettyCommaSeparated prettyCompStmt quals - in prettyExpr body <> hardline <> " |" <+> qualifiers + in group (prettyExpr body <> spacedLine <> "|" <+> qualifiers) ) EListCompParallel body qualifierGroups -> brackets ( let qualifiers = prettyBarSeparated - [ prettyCommaSeparated prettyCompStmt group - | group <- qualifierGroups + [ prettyCommaSeparated prettyCompStmt qualifierGroup + | qualifierGroup <- qualifierGroups ] - in prettyExpr body <> hardline <> " |" <+> qualifiers + in group (prettyExpr body <> spacedLine <> "|" <+> qualifiers) ) EArithSeq seqInfo -> prettyArithSeq seqInfo ERecordCon name fields hasWildcard -> - prettyPrefixName name <+> braces (hsep (punctuate comma (map prettyBinding fields ++ [".." | hasWildcard]))) + prettyPrefixName name <+> braces (prettyCommaBlock (map prettyBinding fields ++ [".." | hasWildcard])) ERecordUpd base fields -> - prettyExpr base <+> braces (hsep (punctuate comma (map prettyBinding fields))) + prettyExpr base <+> braces (prettyCommaBlock (map prettyBinding fields)) EGetField base field -> prettyExpr base <> "." <> prettyName field EGetFieldProjection fields -> "." <> mconcat (punctuate "." (map prettyName fields)) ETypeSig inner ty -> - nest 2 (prettyExpr inner) <> nest 1 (hardline <> "::" <+> prettyType ty) + group (nest 2 (prettyExpr inner) <> nest 1 (line <> "::" <+> prettyType ty)) EParen inner -> case inner of ECase scrutinee alts -> parens (prettyCaseExpr prettyCaseLayout scrutinee alts) @@ -1309,24 +1372,59 @@ prettyAppWith :: (Expr -> Doc ann) -> Expr -> Doc ann prettyAppWith prettyFn expr = let (fn, args) = flattenApps expr - in prettyFn fn <> nest 2 (hardline <> vsep (map prettyExpr args)) + in prettyFn fn <> nest 2 (softline <> fillArguments args) where + -- Put as many arguments on a line as fit. After an argument that ends + -- with a layout block, start a new line: text on the same line goes into + -- the block. + fillArguments [] = mempty + fillArguments [arg] = prettyExpr arg + fillArguments (arg : rest) = + prettyExpr arg <> (if endsWithLayoutBlock arg then hardline else softline) <> fillArguments rest flattenApps = go [] go args (EAnn _ sub) = go args sub go args (EApp fn arg) = go (arg : args) fn go args root = (root, args) +-- | The printed expression ends with a layout block that has no closing token. +endsWithLayoutBlock :: Expr -> Bool +endsWithLayoutBlock expr = + case expr of + EAnn _ sub -> endsWithLayoutBlock sub + ECase {} -> True + EDo {} -> True + ELambdaCase {} -> True + ELambdaCases {} -> True + EMultiWayIf {} -> True + ELetDecls _ body -> endsWithLayoutBlock body + ELambdaPats _ body -> endsWithLayoutBlock body + EIf _ _ no -> endsWithLayoutBlock no + EApp _ arg -> endsWithLayoutBlock arg + EInfix _ _ rhs -> endsWithLayoutBlock rhs + ENegate inner -> endsWithLayoutBlock inner + EProc {} -> True + _ -> False + prettyCommaSeparated :: (a -> Doc ann) -> [a] -> Doc ann prettyCommaSeparated render items = case map render items of [] -> mempty - rendered -> hsep (punctuate comma rendered) + rendered -> prettyCommaBlock rendered +-- | Items separated by commas. Each line gets as many items as fit. +prettyCommaFill :: [Doc ann] -> Doc ann +prettyCommaFill items = nest 2 (concatWith (\x y -> x <> comma <> softline <> y) items) + +-- | Items separated by commas. When they do not fit on the line, each item +-- after the first starts a new line. +prettyCommaBlock :: [Doc ann] -> Doc ann +prettyCommaBlock items = group (nest 2 (concatWith (\x y -> x <> comma <> line <> y) items)) + prettyBarSeparated :: [Doc ann] -> Doc ann prettyBarSeparated items = case items of [] -> mempty - firstItem : restItems -> hang 1 (vsep (firstItem : map ("|" <+>) restItems)) + firstItem : restItems -> group (hang 1 (vsep (firstItem : map ("|" <+>) restItems))) prettyTupleBody :: TupleFlavor -> Doc ann -> Doc ann prettyTupleBody tupleFlavor inner = @@ -1360,23 +1458,25 @@ prettyGuardedRhsBodyBlock arrow grhs = let guards = guardedRhsGuards grhs body = guardedRhsBody grhs - in "|" - <+> prettyGuardQualifiersLayout guards - <> hardline - <> " " - <> pretty arrow - <+> prettyExpr body + in group + ( "|" + <+> prettyGuardQualifiersLayout guards + <> spacedLine + <> pretty arrow + <+> prettyExpr body + ) prettyCaseGuardedRhsBlock :: (body -> Doc ann) -> GuardedRhs body -> Doc ann prettyCaseGuardedRhsBlock prettyBody grhs = let guards = guardedRhsGuards grhs body = guardedRhsBody grhs - in "|" - <+> prettyGuardQualifiersLayout guards - <> hardline - <> " " - <> "->" - <+> nest 2 (prettyBody body) + in group + ( "|" + <+> prettyGuardQualifiersLayout guards + <> spacedLine + <> "->" + <+> nest 2 (prettyBody body) + ) prettyGuardedCaseAlt :: Doc ann -> (body -> Doc ann) -> [GuardedRhs body] -> Doc ann prettyGuardedCaseAlt headDoc prettyBody grhss = @@ -1384,18 +1484,46 @@ [] -> headDoc [firstGrhs] -> headDoc <+> firstGrhs firstGrhs : restGrhss -> - headDoc <+> firstGrhs <> nest 2 (hardline <> vsep restGrhss) + headDoc <+> firstGrhs <> nest 2 (hardline <> hardVsep restGrhss) prettyMultiWayIfRhss :: [GuardedRhs Expr] -> Doc ann -prettyMultiWayIfRhss rhss = vsep (map (prettyGuardedRhsBodyBlock "->") rhss) +prettyMultiWayIfRhss rhss = hardVsep (map (prettyGuardedRhsBodyBlock "->") rhss) +-- | Put the alternatives of a multi-way @if@ in a layout block that starts to +-- the right of the @if@ keyword and also to the right of the current +-- indentation. +-- +-- The alternatives are an implicit layout block that opens at the first @|@. +-- A later line at the same column as that @|@, or further right, continues the +-- last alternative. It does not close the block. The enclosing expression +-- puts its continuation lines relative to the current indentation, which can +-- be further right than the @if@ keyword. Thus the block must also clear the +-- indentation, or the printed module does not parse to the same syntax tree. +prettyMultiWayIfBlock :: Doc ann -> Doc ann +prettyMultiWayIfBlock alternatives = + column + ( \col -> + nesting + ( \indent -> + let target = max (col + 1) (indent + multiWayIfBarOffset) + in pretty (T.replicate (target - col) " ") <> nest (target - indent) alternatives + ) + ) + +-- | The least distance between the current indentation and the @|@ of a +-- multi-way @if@. Each continuation line that the pretty-printer puts after a +-- sub-expression is at most two columns to the right of the indentation of that +-- sub-expression. Three columns thus always close the block. +multiWayIfBarOffset :: Int +multiWayIfBarOffset = 3 + prettyGuardQualifiersLayout :: [GuardQualifier] -> Doc ann prettyGuardQualifiersLayout qualifiers = case map prettyGuardQualifier qualifiers of [] -> mempty [firstQualifier] -> firstQualifier firstQualifier : restQualifiers -> - firstQualifier <> nest 2 (hardline <> vsep (map (comma <+>) restQualifiers)) + group (firstQualifier <> nest 2 (line' <> concatWith (\x y -> x <> line' <> y) (map (comma <+>) restQualifiers))) prettyCaseExpr :: ([Doc ann] -> Doc ann) -> Expr -> [CaseAlt Expr] -> Doc ann prettyCaseExpr layout scrutinee alts = @@ -1406,7 +1534,7 @@ prettyCaseLayout :: [Doc ann] -> Doc ann prettyCaseLayout [] = " " <> spacedBraces mempty -prettyCaseLayout alts = nest 2 (hardline <> vsep alts) +prettyCaseLayout alts = nest 2 (hardline <> hardVsep alts) prettyLambdaCaseAlt :: LambdaCaseAlt -> Doc ann prettyLambdaCaseAlt (LambdaCaseAlt _ pats rhs) = @@ -1426,13 +1554,15 @@ GuardAnn _ inner -> prettyGuardQualifier inner GuardExpr expr -> prettyExpr expr GuardPat pat expr -> prettyPattern pat <+> "<-" <+> prettyExpr expr - GuardLet decls -> prettyLetDecls decls + -- The let block has no closing token. On one line, the guard arrow can + -- go into the block, for example into a type signature. + GuardLet decls -> prettyLetDecls decls <> noFlat prettyLetDecls :: [Decl] -> Doc ann prettyLetDecls decls | null decls = "let" <+> spacedBraces mempty | otherwise = - "let" <+> align (vsep (concatMap prettyDeclLines decls)) + "let" <+> align (hardVsep (concatMap prettyDeclLines decls)) prettyDoFlavor :: DoFlavor -> Doc ann prettyDoFlavor DoPlain = "do" @@ -1450,7 +1580,7 @@ prettyLayoutStatements prettyStmt stmts = case map prettyStmt stmts of [] -> mempty - rendered -> vsep rendered + rendered -> hardVsep rendered prettyDoStmt :: DoStmt Expr -> Doc ann prettyDoStmt stmt = @@ -1469,12 +1599,12 @@ EAnn _ sub -> prettyExprAtStatementStart sub EOverloadedLabel _ raw -> pretty raw EApp {} -> prettyAppWith prettyExprAtStatementStart expr - ETypeApp fn ty -> nest 2 (prettyExprAtStatementStart fn) <> nest 1 (hardline <> " " <> prettyTypeAppArg ty) - EInfix lhs op rhs -> nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (hardline <> prettyNameInfixOp op <+> prettyExpr rhs) - ESectionL lhs op -> nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (hardline <> " " <> prettyNameInfixOp op) - ETypeSig inner ty -> nest 2 (prettyExprAtStatementStart inner) <> nest 1 (hardline <> "::" <+> prettyType ty) + ETypeApp fn ty -> group (nest 2 (prettyExprAtStatementStart fn) <> nest 1 (spacedLine <> prettyTypeAppArg ty)) + EInfix lhs op rhs -> group (nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (line <> prettyNameInfixOp op <+> prettyExpr rhs)) + ESectionL lhs op -> group (nest 2 (prettyExprAtStatementStart lhs) <> nest 1 (spacedLine <> prettyNameInfixOp op)) + ETypeSig inner ty -> group (nest 2 (prettyExprAtStatementStart inner) <> nest 1 (line <> "::" <+> prettyType ty)) ERecordUpd base fields -> - prettyExprAtStatementStart base <+> braces (hsep (punctuate comma (map prettyBinding fields))) + prettyExprAtStatementStart base <+> braces (prettyCommaBlock (map prettyBinding fields)) EGetField base field -> prettyExprAtStatementStart base <> "." <> prettyName field _ -> prettyExpr expr @@ -1489,17 +1619,17 @@ CmdArrApp lhs HsHigherOrderApp rhs -> prettyExpr lhs <+> "-<<" <+> prettyExpr rhs CmdInfix l op r -> - nest 2 (prettyCmd l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r) + group (nest 2 (prettyCmd l) <> nest 1 (spacedLine <> prettyNameInfixOp op <+> prettyCmd r)) CmdDo stmts -> "do" <> nest 2 (prettyDoLayout prettyCmdStmt stmts) CmdIf cond yes no -> - "if" <+> prettyExpr cond <+> "then" <+> prettyCmd yes <+> "else" <+> prettyCmd no + group ("if" <+> prettyExpr cond <> nest 2 (line <> "then" <+> prettyCmd yes <> line <> "else" <+> prettyCmd no)) CmdCase scrut alts -> "case" <+> prettyExpr scrut <+> "of" <> prettyCaseLayout (map prettyCmdCaseAlt alts) CmdLet decls body -> case decls of [] -> prettyLetDecls decls <+> "in" <+> prettyCmd body - _ -> align (prettyLetDecls decls <> nest 2 (hardline <> "in" <+> prettyCmd body)) + _ -> group (align (prettyLetDecls decls <> nest 2 (line <> "in" <+> prettyCmd body))) CmdLam pats body -> "\\" <+> hsep (map prettyPattern pats) <+> "->" <+> prettyCmd body CmdApp c e -> @@ -1526,7 +1656,7 @@ CmdArrApp lhs HsHigherOrderApp rhs -> prettyExprAtStatementStart lhs <+> "-<<" <+> prettyExpr rhs CmdInfix l op r -> - nest 2 (prettyCmdAtStatementStart l) <> nest 1 (hardline <> " " <> prettyNameInfixOp op <+> prettyCmd r) + group (nest 2 (prettyCmdAtStatementStart l) <> nest 1 (spacedLine <> prettyNameInfixOp op <+> prettyCmd r)) CmdApp c e -> prettyCmdAtStatementStart c <+> prettyExpr e _ -> prettyCmd cmd @@ -1548,7 +1678,7 @@ prettyGuardedRhssBlock :: [GuardedRhs Expr] -> Maybe [Decl] -> Doc ann prettyGuardedRhssBlock guards whereDecls = - vsep (map prettyGuardedRhsBlock guards) + hardVsep (map prettyGuardedRhsBlock guards) <> case whereDecls of Nothing -> mempty Just _ -> hardline <> prettyWhereClauseBare whereDecls @@ -1599,7 +1729,7 @@ ["=", prettyTyVarBinder result, "|", prettyTypeFamilyInjectivity injectivity] eqsPart Nothing = [] eqsPart (Just []) = ["where", spacedBraces mempty] - eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> vsep (map prettyTypeFamilyEq eqs))] + eqsPart (Just eqs) = ["where" <> nest 2 (hardline <> hardVsep (map prettyTypeFamilyEq eqs))] prettyTypeFamilyEq :: TypeFamilyEq -> Doc ann prettyTypeFamilyEq eq = diff --git a/src/Aihc/Parser/Shorthand.hs b/src/Aihc/Parser/Shorthand.hs --- a/src/Aihc/Parser/Shorthand.hs +++ b/src/Aihc/Parser/Shorthand.hs @@ -855,6 +855,7 @@ PStrict inner -> "PStrict" <+> parens (docPattern inner) PIrrefutable inner -> "PIrrefutable" <+> parens (docPattern inner) PNegLit lit -> "PNegLit" <+> parens (docLiteral lit) + PNPlusK name lit -> "PNPlusK" <+> docUnqualifiedName name <+> parens (docLiteral lit) PParen inner -> "PParen" <+> parens (docPattern inner) PRecord name fields' hasWildcard -> "PRecord" <+> docName name <+> braces (hsep (punctuate comma ([docPatternRecordField recordField | recordField <- fields'] ++ [".." | hasWildcard]))) PTypeSig inner ty -> "PTypeSig" <+> parens (docPattern inner) <+> parens (docType ty) 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 @@ -1439,6 +1439,9 @@ PIrrefutable Pattern | -- | @-1@ PNegLit Literal + | -- | @n+1@, an n+k pattern. It needs the @NPlusKPatterns@ extension. + -- The literal is always a non-negative integer literal. + PNPlusK UnqualifiedName Literal | -- | @(pat)@ PParen Pattern | -- | @T { x = p, y, .. }@ 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 @@ -7,11 +7,17 @@ module Aihc.Parser.Types ( TokStream (..), + TraceEntry (..), + Trace (..), mkTokStream, mkTokStreamModule, mkTokStreamFromTokens, setTokStreamLayout, setTokStreamPendingPragmas, + enableTokStreamTrace, + discardLastTraceEntry, + discardTraceEntriesFrom, + discardTraceRange, runTokStreamParser, ParserErrorComponent (..), FoundToken (..), @@ -101,6 +107,10 @@ -- | Whether this stream has already emitted TkEOF. -- After EOF is emitted, 'take1_' returns Nothing. tokStreamEOFEmitted :: !Bool, + -- | The tokens that the parser took from this stream, newest first. The + -- trace is 'Nothing' unless a caller enables it with + -- 'enableTokStreamTrace', because a trace keeps every token alive. + tokStreamTrace :: !(Maybe Trace), -- | Memoized result of stepping this stream by one token. Lookahead and -- backtracking step the same position many times; sharing the successor -- means the layout transition for each raw token runs once. @@ -110,6 +120,22 @@ tokStreamNext :: Maybe (LexToken, TokStream) } +-- | One token that the parser took from the stream. The token can be real or +-- virtual. A discarded token is a token that the parser took but did not keep +-- in the AST, for example a trailing comma or an extra semicolon. +data TraceEntry = TraceEntry + { traceToken :: !LexToken, + traceDiscarded :: !Bool + } + deriving (Eq, Show, Generic, NFData) + +-- | The entries of a token trace, newest first, with their count. +data Trace = Trace + { traceLength :: !Int, + traceEntries :: [TraceEntry] + } + deriving (Eq, Show, Generic, NFData) + -- -- Manual Eq instance — we skip tokStreamRawTokens since list position is not -- -- efficiently comparable and Megaparsec tracks offset separately. -- instance Eq TokStream where @@ -158,6 +184,7 @@ Nothing (mkExtensionSet exts) False + Nothing -- | Create a TokStream for parsing full modules (with module-body layout). -- Also bootstraps LANGUAGE pragma extensions from the module header. @@ -172,6 +199,7 @@ Nothing (mkExtensionSet effectiveExts) False + Nothing where headerSettings = readModuleHeaderExtensions input effectiveExts = applyImpliedExtensions (foldr applyExtensionSetting baseExts headerSettings) @@ -189,6 +217,7 @@ Nothing (mkExtensionSet []) False + Nothing -- | Replace the layout state and buffer of a stream. The result is a fresh -- stream with a consistent memoized successor. @@ -202,6 +231,7 @@ (tokStreamPrevToken ts) (tokStreamExtensionSet ts) (tokStreamEOFEmitted ts) + (tokStreamTrace ts) -- | Replace the pending hidden pragmas of a stream. setTokStreamPendingPragmas :: [Pragma] -> TokStream -> TokStream @@ -214,10 +244,71 @@ (tokStreamPrevToken ts) (tokStreamExtensionSet ts) (tokStreamEOFEmitted ts) + (tokStreamTrace ts) +-- | Start the trace of a stream. The trace then records each token that the +-- parser takes. Use 'discardLastTraceEntry' to mark a token that the AST does +-- not keep. +enableTokStreamTrace :: TokStream -> TokStream +enableTokStreamTrace ts = + buildTokStream + (tokStreamRawTokens ts) + (tokStreamLayoutState ts) + (tokStreamBuffer ts) + (tokStreamPendingPragmas ts) + (tokStreamPrevToken ts) + (tokStreamExtensionSet ts) + (tokStreamEOFEmitted ts) + (Just (Trace 0 [])) + +-- | Mark the newest trace entry as discarded. This has no effect when the +-- trace is not enabled. +discardLastTraceEntry :: TokStream -> TokStream +discardLastTraceEntry ts = + case tokStreamTrace ts of + Just (Trace len _) -> discardTraceEntriesFrom (len - 1) ts + Nothing -> ts + +-- | Mark each trace entry from the given position as discarded. Position 0 is +-- the oldest entry. Use the 'traceLength' from before a parser to mark each +-- token that the parser took. This has no effect when the trace is not +-- enabled. +discardTraceEntriesFrom :: Int -> TokStream -> TokStream +discardTraceEntriesFrom start ts = + case tokStreamTrace ts of + Just (Trace len _) -> discardTraceRange start len ts + Nothing -> ts + +-- | Mark the trace entries at positions @start@ to @end - 1@ as discarded. +-- Position 0 is the oldest entry. This has no effect when the trace is not +-- enabled. +discardTraceRange :: Int -> Int -> TokStream -> TokStream +discardTraceRange start end ts = + case tokStreamTrace ts of + Just (Trace len entries) + | start < end && start < len -> + buildTokStream + (tokStreamRawTokens ts) + (tokStreamLayoutState ts) + (tokStreamBuffer ts) + (tokStreamPendingPragmas ts) + (tokStreamPrevToken ts) + (tokStreamExtensionSet ts) + (tokStreamEOFEmitted ts) + (Just (Trace len (markRange entries))) + where + -- The entries are newest first, so position p is at index len - 1 - p. + newest = len - min end len + count = min end len - start + markRange entries' = + let (newer, rest) = splitAt newest entries' + (marked, older) = splitAt count rest + in newer <> map (\entry -> entry {traceDiscarded = True}) marked <> older + _ -> ts + -- | Build a stream whose memoized successor is computed from its fields. -buildTokStream :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> TokStream -buildTokStream rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted = +buildTokStream :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> Maybe Trace -> TokStream +buildTokStream rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted trace = let ts = TokStream { tokStreamRawTokens = rawTokens, @@ -227,6 +318,7 @@ tokStreamPrevToken = prevToken, tokStreamExtensionSet = extensionSet, tokStreamEOFEmitted = eofEmitted, + tokStreamTrace = trace, tokStreamNext = stepOne ts } in ts @@ -234,13 +326,13 @@ -- | Advance through layout and hidden tokens until the stream is ready for -- 'stepOne'. Keeping the stream fields separate lets a token step normalize -- its successor without first allocating an intermediate 'TokStream'. -normalizeTokStreamParts :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> TokStream -normalizeTokStreamParts rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted +normalizeTokStreamParts :: [LexToken] -> LayoutState -> [LexToken] -> [Pragma] -> Maybe LexToken -> ExtensionSet -> Bool -> Maybe Trace -> TokStream +normalizeTokStreamParts rawTokens layoutState buffer pendingPragmas prevToken extensionSet eofEmitted trace | eofEmitted = finish rawTokens layoutState buffer pendingPragmas | otherwise = go rawTokens layoutState buffer pendingPragmas where finish rawTokens' layoutState' buffer' pendingPragmas' = - buildTokStream rawTokens' layoutState' buffer' pendingPragmas' prevToken extensionSet eofEmitted + buildTokStream rawTokens' layoutState' buffer' pendingPragmas' prevToken extensionSet eofEmitted trace go rawTokens' layoutState' buffer' pendingPragmas' = case buffer' of @@ -300,6 +392,7 @@ (Just tok) (tokStreamExtensionSet ts) isEOF + (fmap (\(Trace len entries) -> Trace (len + 1) (TraceEntry tok False : entries)) (tokStreamTrace ts)) in Just (tok, next) [] -> Nothing @@ -352,7 +445,7 @@ }, MP.stateParseErrors = [] } - detachedStream = buildTokStream [] (tokStreamLayoutState ts) [] [] Nothing (tokStreamExtensionSet ts) True + detachedStream = buildTokStream [] (tokStreamLayoutState ts) [] [] Nothing (tokStreamExtensionSet ts) True Nothing instance Stream TokStream where type Token TokStream = LexToken diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -147,6 +147,20 @@ ParseErr bundle -> assertFailure ("expected parse success for " <> T.unpack source <> "\n" <> formatParseErrors "" Nothing bundle) +assertParsedStrippedModuleShapeRoundTrip :: ParserConfig -> Text -> Assertion +assertParsedStrippedModuleShapeRoundTrip config source = + case parseModule config source of + ([], modu) -> + let stripped = stripParens (stripAnnotations modu) + rendered = renderPretty stripped + in case parseModule config rendered of + ([], reparsed) -> + assertEqualShorthand (T.unpack rendered) stripped (stripAnnotations (stripParens reparsed)) + (errs, _) -> + assertFailure ("expected pretty-printed module to reparse, got:\n" <> formatParseErrors "" (Just rendered) errs) + (errs, _) -> + assertFailure ("expected parse success for:\n" <> T.unpack source <> "\n" <> formatParseErrors "" (Just source) errs) + assertParsedModulePrettyContains :: Text -> Text -> Assertion assertParsedModulePrettyContains source expected = case parseModule defaultConfig source of @@ -290,10 +304,13 @@ testCase "generated expressions can include explicit type syntax" test_generatedExpressionsCanIncludeExplicitTypeSyntax, testCase "pretty-prints negated layout-ending list-comprehension bodies" test_prettyNegatedLayoutEndingListCompBody, testCase "pretty-prints layout let guards in multi-way if" test_prettyLayoutLetGuardInMultiWayIf, + testCase "pretty-prints typed let guards in case alternatives on separate lines" test_prettyTypedLetGuardInCaseAlt, testCase "pretty-prints multi-way if left operands using layout" test_prettyMultiWayIfInfixLhs, testCase "pretty-prints multi-way if left operands inside do using layout" test_prettyMultiWayIfInfixLhsInsideDo, testCase "pretty-prints multi-way if left operands inside unboxed tuples with parentheses" test_prettyMultiWayIfInfixLhsInsideUnboxedTuple, testCase "pretty-prints multi-way if left operands inside unboxed sums with parentheses" test_prettyMultiWayIfInfixLhsInsideUnboxedSum, + testCase "pretty-prints multi-way if left operands in infix chains using layout" test_prettyMultiWayIfNestedInfixLhs, + testCase "pretty-prints multi-way if parallel comprehension bodies using layout" test_prettyMultiWayIfParallelListCompBody, testCase "pretty-prints lambda-case applicative chains without extra parens" test_prettyLambdaCaseApplicativeChain, testCase "pretty-prints TH splices before record dots with parentheses" test_prettySpliceRecordDotBase, testCase "rejects compact explicit type namespace TH splices" test_compactExplicitTypeNamespaceTHSplicesReject, @@ -324,6 +341,12 @@ testCase "parenthesizes multi-way if view expressions ending with type signatures in decls" test_viewExprMultiWayIfTypeSigParens, testCase "parenthesizes infix view expressions in lambda-cases" test_viewExprInfixLambdaCasesParens, testCase "leaves block infix lhs view expressions bare" test_viewExprBlockInfixLhsNoParens, + testCase "breaks a long record after each comma" test_prettyLongRecordBreaksAfterCommas, + testCase "fills the arguments of a long application" test_prettyLongApplicationFillsArguments, + testCase "breaks a long type signature before each arrow" test_prettyLongTypeSignatureBreaksArrows, + testCase "breaks a long data declaration before each constructor" test_prettyLongDataDeclBreaksConstructors, + testCase "fills a long import list" test_prettyLongImportListFills, + testCase "breaks a long instance head after its context" test_prettyLongInstanceHeadBreaksContext, testCase "leaves view expression block arguments bare" test_viewExprBlockArgumentNoParens, testCase "leaves multi-way-if app infix lhs view expressions bare" test_viewExprMultiWayIfAppInfixLhsNoParens, testCase "parenthesizes non-final let block arguments in view expressions" test_viewExprNonfinalLetBlockArgumentParens, @@ -1407,6 +1430,18 @@ """ assertParsedStrippedExprShapeRoundTrip config source +test_prettyTypedLetGuardInCaseAlt :: Assertion +test_prettyTypedLetGuardInCaseAlt = do + let config = defaultConfig {parserExtensions = [LambdaCase]} + source = + """ + \\case + _ | let _ = [] + :: _ + -> [] + """ + assertParsedStrippedExprShapeRoundTrip config source + test_prettyMultiWayIfInfixLhs :: Assertion test_prettyMultiWayIfInfixLhs = do let config = defaultConfig {parserExtensions = [MultiWayIf]} @@ -1457,6 +1492,43 @@ """ assertParsedStrippedExprShapeRoundTrip config source +-- Two levels of infix nesting put the continuation line at the column of the +-- @|@ of the multi-way if. The @|@ must thus move to the right of the +-- continuation line. See issue #54. +test_prettyMultiWayIfNestedInfixLhs :: Assertion +test_prettyMultiWayIfNestedInfixLhs = do + let config = defaultConfig {parserExtensions = [MultiWayIf]} + source = + """ + ((if | True + -> + ()) + `a` ()) + `a` () + """ + assertParsedStrippedExprShapeRoundTrip config source + +-- The @|@ of a parallel list comprehension can land at the column of the @|@ +-- of a multi-way if in the body of that comprehension. See issue #54. +test_prettyMultiWayIfParallelListCompBody :: Assertion +test_prettyMultiWayIfParallelListCompBody = do + let config = + defaultConfig + { parserExtensions = [MultiWayIf, ImplicitParams, UnboxedSums, ParallelListComp] + } + source = + """ + _ = [] + where + ?x = (# ([(if | [] + -> + []) + | [] + | let { }] + `a` []) | | #) + """ + assertParsedStrippedModuleShapeRoundTrip config source + test_prettyLambdaCaseApplicativeChain :: Assertion test_prettyLambdaCaseApplicativeChain = do let config = defaultConfig {parserExtensions = [LambdaCase]} @@ -1801,6 +1873,42 @@ assertParsedStrippedDeclShapeRoundTrip config "_ = [] where ((do [] `a` []) -> _) = []" assertParsedStrippedPatternShapeRoundTrip config "(((if | [] -> []) `a` []) -> _)" +test_prettyLongRecordBreaksAfterCommas :: Assertion +test_prettyLongRecordBreaksAfterCommas = + assertParsedModulePrettyContains + "module M where\nr = R {fieldOne = valueOne, fieldTwo = valueTwo, fieldThree = valueThree, fieldFour = valueFour}\n" + "r = R {fieldOne = valueOne,\n fieldTwo = valueTwo,\n fieldThree = valueThree,\n fieldFour = valueFour}" + +test_prettyLongApplicationFillsArguments :: Assertion +test_prettyLongApplicationFillsArguments = + assertParsedModulePrettyContains + "module M where\nf = someFunction argumentOne argumentTwo argumentThree argumentFour argumentFive argumentSix\n" + "f = someFunction argumentOne argumentTwo argumentThree argumentFour argumentFive\n argumentSix" + +test_prettyLongTypeSignatureBreaksArrows :: Assertion +test_prettyLongTypeSignatureBreaksArrows = + assertParsedModulePrettyContains + "module M where\nf :: FirstArgumentType -> SecondArgumentType -> ThirdArgumentType -> FourthArgumentType -> ResultType\n" + "f :: FirstArgumentType\n -> SecondArgumentType\n -> ThirdArgumentType\n -> FourthArgumentType\n -> ResultType" + +test_prettyLongDataDeclBreaksConstructors :: Assertion +test_prettyLongDataDeclBreaksConstructors = + assertParsedModulePrettyContains + "module M where\ndata Colour = Red | Green | Blue | Cyan | Magenta | Yellow | Black | White deriving (Eq, Show)\n" + "data Colour\n = Red\n | Green\n | Blue\n | Cyan\n | Magenta\n | Yellow\n | Black\n | White\n deriving (Eq, Show)" + +test_prettyLongImportListFills :: Assertion +test_prettyLongImportListFills = + assertParsedModulePrettyContains + "module M where\nimport Data.List (sortBy, groupBy, intercalate, isPrefixOf, isSuffixOf, partition)\n" + "import Data.List (sortBy, groupBy, intercalate, isPrefixOf, isSuffixOf,\n partition)" + +test_prettyLongInstanceHeadBreaksContext :: Assertion +test_prettyLongInstanceHeadBreaksContext = + assertParsedModulePrettyContains + "module M where\ninstance (Show a, Show b, Show c, Show d) => Show (VeryLongTypeName a b c d) where\n show _ = \"\"\n" + "instance (Show a, Show b, Show c, Show d)\n => Show (VeryLongTypeName a b c d) where" + test_viewExprBlockInfixLhsNoParens :: Assertion test_viewExprBlockInfixLhsNoParens = do let source = @@ -1813,9 +1921,7 @@ """ expected = """ - f [case [] of { } - + [] - -> _] = [] + f [case [] of { } + [] -> _] = [] """ assertParsedModulePrettyContains source expected diff --git a/test/Test/Fixtures/golden/pattern/n-plus-k.yaml b/test/Test/Fixtures/golden/pattern/n-plus-k.yaml new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/golden/pattern/n-plus-k.yaml @@ -0,0 +1,6 @@ +extensions: [NPlusKPatterns] +input: | + n+1 +ast: |- + PNPlusK UnqualifiedName {"n"} (LitInt 1 TInteger) +status: pass diff --git a/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-casealt.hs b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-casealt.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-casealt.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NPlusKPatterns #-} + +module NPlusKPatternsCaseAlt where + +predecessor x = case x of + 0 -> 0 + n+1 -> n diff --git a/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-funarg.hs b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-funarg.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-funarg.hs @@ -0,0 +1,7 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NPlusKPatterns #-} + +module NPlusKPatternsFunArg where + +takeN 0 _ = [] +takeN (n+1) (x:xs) = x : takeN n xs diff --git a/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-patbind.hs b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-patbind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-patbind.hs @@ -0,0 +1,12 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NPlusKPatterns #-} + +module NPlusKPatternsPatBind where + +(m+1) = 3 + +n + 1 = n + +value = xs + where + (k+1 : xs) = [3, 4] diff --git a/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-typed-patbind.hs b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-typed-patbind.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/NPlusKPatterns/npluskpatterns-typed-patbind.hs @@ -0,0 +1,11 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE NPlusKPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module NPlusKPatternsTypedPatBind where + +a + 0 :: Int = 5 + +b + 0 : bs :: [Int] = [5] + +n + 1 = n diff --git a/test/Test/Fixtures/oracle/TransformListComp/transform-case-before-keyword.hs b/test/Test/Fixtures/oracle/TransformListComp/transform-case-before-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/transform-case-before-keyword.hs @@ -0,0 +1,8 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE TransformListComp #-} + +module TransformCaseBeforeKeyword where + +grouped xs = [x | x <- xs, then group by case x of _ -> x using groupWith] + +sorted xs = [x | x <- xs, then sortWith by case x of _ -> x] diff --git a/test/Test/Fixtures/oracle/TransformListComp/transform-multiway-if-before-keyword.hs b/test/Test/Fixtures/oracle/TransformListComp/transform-multiway-if-before-keyword.hs new file mode 100644 --- /dev/null +++ b/test/Test/Fixtures/oracle/TransformListComp/transform-multiway-if-before-keyword.hs @@ -0,0 +1,9 @@ +{- ORACLE_TEST pass -} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TransformListComp #-} + +module TransformMultiWayIfBeforeKeyword where + +grouped xs = [x | x <- xs, then group by if | x -> x using groupWith] + +sorted xs = [x | x <- xs, then sortWith by if | x -> x] diff --git a/test/Test/Oracle/Suite.hs b/test/Test/Oracle/Suite.hs --- a/test/Test/Oracle/Suite.hs +++ b/test/Test/Oracle/Suite.hs @@ -5,8 +5,12 @@ ) where +import Aihc.Parser (ParserConfig (..), TraceEntry (..), defaultConfig, parseModuleWithTrace, tokenKindWithoutSpacing) +import Aihc.Parser.Lex (LexToken (..)) +import Aihc.Parser.Syntax qualified as Syntax import Control.Monad (when) import Data.Text (Text) +import Data.Text qualified as T import Data.Text.IO qualified as TIO import ExtensionSupport ( CaseMeta (..), @@ -16,7 +20,10 @@ evaluateCaseFromFile, evaluateCaseText, loadOracleCases, + preprocessCaseSource, ) +import Prettyprinter (Pretty (..), defaultLayoutOptions, layoutPretty) +import Prettyprinter.Render.Text (renderStrict) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (Assertion, assertFailure, testCase, testCaseInfo) @@ -26,7 +33,56 @@ checks <- mapM mkCaseTest cases framework <- frameworkTests summary <- mkSummaryTest cases - pure (testGroup "oracle" (checks <> [framework, summary])) + traces <- mapM mkTraceTest (filter ((== ExpectPass) . caseExpected) cases) + pure (testGroup "oracle" (checks <> [framework, summary, testGroup "token trace" traces])) + +-- | The parser gives the same token trace for a source file and for its +-- pretty-printed form, when the discarded tokens are removed. A formatter +-- pairs the tokens of the two files by their position in this trace. +mkTraceTest :: CaseMeta -> IO TestTree +mkTraceTest meta = do + source <- TIO.readFile (caseSourcePath meta) + pure (testCase (caseId meta) (assertTraceMatches meta (preprocessCaseSource meta source))) + +assertTraceMatches :: CaseMeta -> Text -> Assertion +assertTraceMatches meta source = + case parseModuleWithTrace config source of + (_ : _, _, _) -> assertFailure "the source does not parse" + ([], modu, sourceTrace) -> + let rendered = renderStrict (layoutPretty defaultLayoutOptions (pretty modu)) + in case parseModuleWithTrace config rendered of + (_ : _, _, _) -> assertFailure "the pretty-printed source does not parse" + ([], _, renderedTrace) -> + let kept = filter (not . traceDiscarded) + sourceKept = kept sourceTrace + renderedKept = kept renderedTrace + kindOf = tokenKindWithoutSpacing . lexTokenKind . traceToken + sameKind a b = kindOf a == kindOf b + common = length (takeWhile id (zipWith sameKind sourceKept renderedKept)) + in when (common < length sourceKept || common < length renderedKept) $ + assertFailure + ( "token traces differ at entry " + <> show common + <> "\nsource: " + <> showEntries (drop (common - 3) sourceKept) + <> "\nrendered: " + <> showEntries (drop (common - 3) renderedKept) + ) + where + config = + defaultConfig + { parserSourceName = caseSourcePath meta, + parserExtensions = Syntax.effectiveExtensions Syntax.Haskell2010Edition (caseExtensions meta) + } + showEntries = unwords . map showEntry . take 7 + showEntry entry = + let tok = traceToken entry + text = lexTokenText tok + in (if T.null text then show (lexTokenKind tok) else T.unpack text) + <> "@" + <> show (Syntax.sourceSpanStartLine (lexTokenSpan tok)) + <> ":" + <> show (Syntax.sourceSpanStartCol (lexTokenSpan tok)) mkCaseTest :: CaseMeta -> IO TestTree mkCaseTest meta = do diff --git a/test/Test/Properties/Arb/Pattern.hs b/test/Test/Properties/Arb/Pattern.hs --- a/test/Test/Properties/Arb/Pattern.hs +++ b/test/Test/Properties/Arb/Pattern.hs @@ -52,6 +52,7 @@ PLit <$> genLiteral, PQuasiQuote <$> genQuoterName <*> genQuasiBody, PNegLit <$> genNumericLiteral, + genNPlusKPattern, PSplice <$> genPatSpliceBody, PTuple Boxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]], PTuple Unboxed <$> elements [[], [PVar (mkUnqualifiedName NameVarId "x")], [PVar (mkUnqualifiedName NameVarId "x"), PWildcard]], @@ -76,6 +77,14 @@ PIrrefutable <$> genPattern ] +-- | Generate an n+k pattern such as @n + 1@. +-- The variable is always a variable identifier and the literal is always a +-- non-negative integer literal, because the n+k syntax allows only these. +genNPlusKPattern :: Gen Pattern +genNPlusKPattern = + (PNPlusK . mkUnqualifiedName NameVarId <$> genVarId) + <*> oneof [mkIntLiteral <$> chooseInteger (0, 999), mkHexLiteral <$> chooseInteger (0, 255)] + genViewPatternWith :: Gen Pattern genViewPatternWith = PView <$> genExpr <*> genPattern @@ -229,6 +238,10 @@ PNegLit lit -> [PLit lit] <> [PNegLit shrunk | shrunk <- shrinkNumericLiteral lit] + PNPlusK name lit -> + [PVar name] + <> [PNPlusK name' lit | name' <- shrinkUnqualifiedName name] + <> [PNPlusK name lit' | lit' <- shrinkLiteral lit] PParen inner -> [inner] <> [PParen inner' | inner' <- shrinkPattern inner] PUnboxedSum altIdx arity inner -> diff --git a/test/Test/Properties/Arb/Utils.hs b/test/Test/Properties/Arb/Utils.hs --- a/test/Test/Properties/Arb/Utils.hs +++ b/test/Test/Properties/Arb/Utils.hs @@ -56,6 +56,7 @@ LinearTypes, MagicHash, MultiWayIf, + NPlusKPatterns, OverloadedLabels, OverloadedRecordDot, ParallelListComp,