From 2ee0dab98d9b1e0aae13b7845f659e184024b494 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Tue, 11 Apr 2023 19:14:55 +0200 Subject: [PATCH] Improve consistency when formatting certain applicands --- CHANGELOG.md | 7 ++ .../value/function/application-1-out.hs | 22 ++--- .../value/function/application-2-out.hs | 12 +-- .../function/arrow/proc-applications2-out.hs | 3 +- .../function/arrow/proc-do-simple1-out.hs | 12 +++ .../value/function/arrow/proc-do-simple1.hs | 10 +++ .../function/arrow/proc-form-do-indent-out.hs | 3 +- .../value/function/multi-way-if-out.hs | 8 +- src/Ormolu/Fixity.hs | 6 +- src/Ormolu/Printer/Combinators.hs | 1 - src/Ormolu/Printer/Internal.hs | 6 -- src/Ormolu/Printer/Meat/Declaration/OpTree.hs | 5 +- src/Ormolu/Printer/Meat/Declaration/Value.hs | 87 ++++++++++--------- .../Printer/Meat/Declaration/Value.hs-boot | 5 +- src/Ormolu/Printer/Operators.hs | 24 ++--- 15 files changed, 121 insertions(+), 90 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 430e6b8c2..3851a2b3c 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +## Unreleased + +* Consistently format `do` blocks/`case`s/`MultiWayIf`s with 4 spaces if and + only if they occur as the applicand. [Issue + 1002](https://github.com/tweag/ormolu/issues/1002) and [issue + 730](https://github.com/tweag/ormolu/issues/730). + ## Ormolu 0.6.0.1 * Fix false positives in AST diffing related to `UnicodeSyntax`. [PR diff --git a/data/examples/declaration/value/function/application-1-out.hs b/data/examples/declaration/value/function/application-1-out.hs index 7b1689a6f..1107bf6d6 100644 --- a/data/examples/declaration/value/function/application-1-out.hs +++ b/data/examples/declaration/value/function/application-1-out.hs @@ -1,19 +1,19 @@ main = do - x - y - z + x + y + z main = case foo of - x -> a - foo - a - b + x -> a + foo + a + b main = do - if x then y else z - foo - a - b + if x then y else z + foo + a + b diff --git a/data/examples/declaration/value/function/application-2-out.hs b/data/examples/declaration/value/function/application-2-out.hs index caa20563e..ce1f6151e 100644 --- a/data/examples/declaration/value/function/application-2-out.hs +++ b/data/examples/declaration/value/function/application-2-out.hs @@ -16,8 +16,8 @@ foo = do foo = do do - (+ 1) - 2 + (+ 1) + 2 foo = do case () of () -> (+ 1) @@ -25,8 +25,8 @@ foo = do foo = do case () of - () -> (+ 1) - 2 + () -> (+ 1) + 2 foo = do \case 2 -> 3 @@ -34,5 +34,5 @@ foo = do foo = do \case - 2 -> 3 - 2 + 2 -> 3 + 2 diff --git a/data/examples/declaration/value/function/arrow/proc-applications2-out.hs b/data/examples/declaration/value/function/arrow/proc-applications2-out.hs index eac7b02f3..cdcf240a0 100644 --- a/data/examples/declaration/value/function/arrow/proc-applications2-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-applications2-out.hs @@ -8,4 +8,5 @@ g x = proc (y, z) -> LT -> \a -> returnA -< x + a EQ -> \b -> returnA -< y + z + b GT -> \c -> returnA -< z + x - ) 1 + ) + 1 diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs index 96961db1c..48569c90c 100644 --- a/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1-out.hs @@ -15,3 +15,15 @@ bazbar f = proc a -> do f -< a + +foo = + proc x -> + do + returnA -< x + 1 + +foo a = + proc x -> + case Left x of + Left x -> returnA -< x + a diff --git a/data/examples/declaration/value/function/arrow/proc-do-simple1.hs b/data/examples/declaration/value/function/arrow/proc-do-simple1.hs index 8c2a9ab79..3a8064f83 100644 --- a/data/examples/declaration/value/function/arrow/proc-do-simple1.hs +++ b/data/examples/declaration/value/function/arrow/proc-do-simple1.hs @@ -18,3 +18,13 @@ bazbar f = proc a -> -< a +foo = + proc x -> do + returnA -< x + 1 + +foo a = + proc x -> + case Left x of + Left x -> returnA -< x + a diff --git a/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs b/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs index b55e8b8ea..6d81249eb 100644 --- a/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs +++ b/data/examples/declaration/value/function/arrow/proc-form-do-indent-out.hs @@ -10,4 +10,5 @@ foo1 x = proc (y, z) -> do (| bar (bindA -< y) - |) z + |) + z diff --git a/data/examples/declaration/value/function/multi-way-if-out.hs b/data/examples/declaration/value/function/multi-way-if-out.hs index b15e12ed9..95a8aa2c9 100644 --- a/data/examples/declaration/value/function/multi-way-if-out.hs +++ b/data/examples/declaration/value/function/multi-way-if-out.hs @@ -4,10 +4,10 @@ foo x = if | x == 5 -> 5 bar x y = if - | x > y -> x - | x < y -> - y - | otherwise -> x + | x > y -> x + | x < y -> + y + | otherwise -> x baz = if diff --git a/src/Ormolu/Fixity.hs b/src/Ormolu/Fixity.hs index dd57983e3..3bfc1e57c 100644 --- a/src/Ormolu/Fixity.hs +++ b/src/Ormolu/Fixity.hs @@ -252,6 +252,6 @@ mergeFixityMaps popularityMap threshold packageMaps = comp (fMax, maxs) x = let fX = f x in if - | fMax < fX -> (fX, x :| []) - | fMax == fX -> (fMax, NE.cons x maxs) - | otherwise -> (fMax, maxs) + | fMax < fX -> (fX, x :| []) + | fMax == fX -> (fMax, NE.cons x maxs) + | otherwise -> (fMax, maxs) diff --git a/src/Ormolu/Printer/Combinators.hs b/src/Ormolu/Printer/Combinators.hs index 694b92192..19e23d20b 100644 --- a/src/Ormolu/Printer/Combinators.hs +++ b/src/Ormolu/Printer/Combinators.hs @@ -21,7 +21,6 @@ module Ormolu.Printer.Combinators newline, inci, inciIf, - inciHalf, askSourceType, askFixityOverrides, askFixityMap, diff --git a/src/Ormolu/Printer/Internal.hs b/src/Ormolu/Printer/Internal.hs index e6a9e4e85..8f73d342c 100644 --- a/src/Ormolu/Printer/Internal.hs +++ b/src/Ormolu/Printer/Internal.hs @@ -20,7 +20,6 @@ module Ormolu.Printer.Internal askFixityOverrides, askFixityMap, inci, - inciHalf, sitcc, Layout (..), enterLayout, @@ -411,11 +410,6 @@ inciBy step (R m) = R (local modRC m) inci :: R () -> R () inci = inciBy indentStep --- | In rare cases, we have to indent by a positive amount smaller --- than 'indentStep'. -inciHalf :: R () -> R () -inciHalf = inciBy $ (indentStep `div` 2) `max` 1 - -- | Set indentation level for the inner computation equal to current -- column. This makes sure that the entire inner block is uniformly -- \"shifted\" to the right. diff --git a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs index 363d044f9..410249e52 100644 --- a/src/Ormolu/Printer/Meat/Declaration/OpTree.hs +++ b/src/Ormolu/Printer/Meat/Declaration/OpTree.hs @@ -23,7 +23,8 @@ import GHC.Types.SrcLoc import Ormolu.Printer.Combinators import Ormolu.Printer.Meat.Common (p_rdrName) import Ormolu.Printer.Meat.Declaration.Value - ( cmdTopPlacement, + ( IsApplicand (..), + cmdTopPlacement, exprPlacement, p_hsCmdTop, p_hsExpr, @@ -91,7 +92,7 @@ p_exprOpTree :: -- operator fixity OpTree (LHsExpr GhcPs) (OpInfo (LHsExpr GhcPs)) -> R () -p_exprOpTree s (OpNode x) = located x (p_hsExpr' s) +p_exprOpTree s (OpNode x) = located x (p_hsExpr' NotApplicand s) p_exprOpTree s t@(OpBranches exprs ops) = do let firstExpr = head exprs otherExprs = tail exprs diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs b/src/Ormolu/Printer/Meat/Declaration/Value.hs index 552c36138..70c0fdb9b 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs @@ -10,6 +10,7 @@ module Ormolu.Printer.Meat.Declaration.Value p_hsExpr, p_hsUntypedSplice, p_stringLit, + IsApplicand (..), p_hsExpr', p_hsCmdTop, exprPlacement, @@ -317,10 +318,10 @@ p_grhs' parentPlacement placer render style (GRHS _ guards body) = p_body = located body render p_hsCmd :: HsCmd GhcPs -> R () -p_hsCmd = p_hsCmd' N +p_hsCmd = p_hsCmd' NotApplicand N -p_hsCmd' :: BracketStyle -> HsCmd GhcPs -> R () -p_hsCmd' s = \case +p_hsCmd' :: IsApplicand -> BracketStyle -> HsCmd GhcPs -> R () +p_hsCmd' isApp s = \case HsCmdArrApp _ body input arrType rightToLeft -> do let (l, r) = if rightToLeft then (body, input) else (input, body) located l p_hsExpr @@ -347,26 +348,26 @@ p_hsCmd' s = \case (reassociateOpTree (getOpName . unLoc) fixityOverrides fixityMap opTree) HsCmdArrForm _ _ Infix _ _ -> notImplemented "HsCmdArrForm" HsCmdApp _ cmd expr -> do - located cmd (p_hsCmd' s) - space - located expr p_hsExpr + located cmd (p_hsCmd' Applicand s) + breakpoint + inci $ located expr p_hsExpr HsCmdLam _ mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup HsCmdPar _ _ c _ -> parens N (located c p_hsCmd) HsCmdCase _ e mgroup -> - p_case cmdPlacement p_hsCmd e mgroup + p_case isApp cmdPlacement p_hsCmd e mgroup HsCmdLamCase _ variant mgroup -> - p_lamcase variant cmdPlacement p_hsCmd mgroup + p_lamcase isApp variant cmdPlacement p_hsCmd mgroup HsCmdIf _ _ if' then' else' -> p_if cmdPlacement p_hsCmd if' then' else' HsCmdLet _ _ localBinds _ c -> p_let p_hsCmd localBinds c HsCmdDo _ es -> do txt "do" - p_stmts cmdPlacement (p_hsCmd' S) es + p_stmts isApp cmdPlacement (p_hsCmd' NotApplicand S) es -- | Print a top-level command. p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () -p_hsCmdTop s (HsCmdTop _ cmd) = located cmd (p_hsCmd' s) +p_hsCmdTop s (HsCmdTop _ cmd) = located cmd (p_hsCmd' NotApplicand s) -- | Render an expression preserving blank lines between such consecutive -- expressions found in the original source code. @@ -472,6 +473,7 @@ p_stmts :: ( Anno (Stmt GhcPs (LocatedA body)) ~ SrcSpanAnnA, Anno [LocatedA (Stmt GhcPs (LocatedA body))] ~ SrcSpanAnnL ) => + IsApplicand -> -- | Placer (body -> Placement) -> -- | Render @@ -479,10 +481,10 @@ p_stmts :: -- | Statements to render LocatedL [LocatedA (Stmt GhcPs (LocatedA body))] -> R () -p_stmts placer render es = do +p_stmts isApp placer render es = do breakpoint ub <- layoutToBraces <$> getLayout - inci . located es $ + inciApplicand isApp . located es $ sepSemi (ub . withSpacing (p_stmt' placer render)) @@ -567,10 +569,24 @@ p_hsFieldBind p_lhs HsFieldBind {..} = do placeHanging placement (located hfbRHS p_hsExpr) p_hsExpr :: HsExpr GhcPs -> R () -p_hsExpr = p_hsExpr' N +p_hsExpr = p_hsExpr' NotApplicand N -p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () -p_hsExpr' s = \case +-- | An applicand is the left-hand side in a function application, i.e. @f@ in +-- @f a@. We need to track this in order to add extra identation in cases like +-- +-- > foo = +-- > do +-- > succ +-- > 1 +data IsApplicand = Applicand | NotApplicand + +inciApplicand :: IsApplicand -> R () -> R () +inciApplicand = \case + Applicand -> inci . inci + NotApplicand -> inci + +p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () +p_hsExpr' isApp s = \case HsVar _ name -> p_rdrName name HsUnboundVar _ occ -> atom occ HsRecSel _ fldOcc -> p_fieldOcc fldOcc @@ -589,7 +605,7 @@ p_hsExpr' s = \case HsLam _ mgroup -> p_matchGroup Lambda mgroup HsLamCase _ variant mgroup -> - p_lamcase variant exprPlacement p_hsExpr mgroup + p_lamcase isApp variant exprPlacement p_hsExpr mgroup HsApp _ f x -> do let -- In order to format function applications with multiple parameters -- nicer, traverse the AST to gather the function and all the @@ -617,35 +633,20 @@ p_hsExpr' s = \case -- one. case placement of Normal -> do - let -- Usually we want to bump indentation for arguments for the - -- sake of readability. However: - -- When the function is itself a multi line do-block or a case - -- expression, we can't indent by indentStep or more. - -- When we are on the other hand *in* a do block, we have to - -- indent by at least 1. - -- Thus, we indent by half of indentStep when the function is - -- a multi line do block or case expression. - indentArg - | isOneLineSpan (getLocA func) = inci - | otherwise = case unLoc func of - HsDo {} -> inciHalf - HsCase {} -> inciHalf - HsLamCase {} -> inciHalf - _ -> inci ub <- getLayout <&> \case SingleLine -> useBraces MultiLine -> id ub $ do - located func (p_hsExpr' s) + located func (p_hsExpr' Applicand s) breakpoint - indentArg $ sep breakpoint (located' p_hsExpr) initp - indentArg $ do + inci $ sep breakpoint (located' p_hsExpr) initp + inci $ do unless (null initp) breakpoint located lastp p_hsExpr Hanging -> do useBraces . switchLayout [initSpan] $ do - located func (p_hsExpr' s) + located func (p_hsExpr' Applicand s) breakpoint sep breakpoint (located' p_hsExpr) initp placeHanging placement . dontUseBraces $ @@ -715,20 +716,20 @@ p_hsExpr' s = \case ExplicitSum _ tag arity e -> p_unboxedSum N tag arity (located e p_hsExpr) HsCase _ e mgroup -> - p_case exprPlacement p_hsExpr e mgroup + p_case isApp exprPlacement p_hsExpr e mgroup HsIf _ if' then' else' -> p_if exprPlacement p_hsExpr if' then' else' HsMultiIf _ guards -> do txt "if" breakpoint - inci . inci $ sep newline (located' (p_grhs RightArrow)) guards + inciApplicand isApp $ sep newline (located' (p_grhs RightArrow)) guards HsLet _ _ localBinds _ e -> p_let p_hsExpr localBinds e HsDo _ doFlavor es -> do let doBody moduleName header = do forM_ moduleName $ \m -> atom m *> txt "." txt header - p_stmts exprPlacement (p_hsExpr' S) es + p_stmts isApp exprPlacement (p_hsExpr' NotApplicand S) es compBody = brackets s . located es $ \xs -> do let p_parBody = sep @@ -911,6 +912,7 @@ p_case :: ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => + IsApplicand -> -- | Placer (body -> Placement) -> -- | Render @@ -920,19 +922,20 @@ p_case :: -- | Match group MatchGroup GhcPs (LocatedA body) -> R () -p_case placer render e mgroup = do +p_case isApp placer render e mgroup = do txt "case" space located e p_hsExpr space txt "of" breakpoint - inci (p_matchGroup' placer render Case mgroup) + inciApplicand isApp (p_matchGroup' placer render Case mgroup) p_lamcase :: ( Anno (GRHS GhcPs (LocatedA body)) ~ SrcAnn NoEpAnns, Anno (Match GhcPs (LocatedA body)) ~ SrcSpanAnnA ) => + IsApplicand -> -- | Variant (@\\case@ or @\\cases@) LamCaseVariant -> -- | Placer @@ -942,12 +945,12 @@ p_lamcase :: -- | Expression MatchGroup GhcPs (LocatedA body) -> R () -p_lamcase variant placer render mgroup = do +p_lamcase isApp variant placer render mgroup = do txt $ case variant of LamCase -> "\\case" LamCases -> "\\cases" breakpoint - inci (p_matchGroup' placer render LambdaCase mgroup) + inciApplicand isApp (p_matchGroup' placer render LambdaCase mgroup) p_if :: -- | Placer diff --git a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot index ecb3ddbec..8a64c512e 100644 --- a/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot +++ b/src/Ormolu/Printer/Meat/Declaration/Value.hs-boot @@ -19,7 +19,10 @@ p_pat :: Pat GhcPs -> R () p_hsExpr :: HsExpr GhcPs -> R () p_hsUntypedSplice :: SpliceDecoration -> HsUntypedSplice GhcPs -> R () p_stringLit :: String -> R () -p_hsExpr' :: BracketStyle -> HsExpr GhcPs -> R () + +data IsApplicand + +p_hsExpr' :: IsApplicand -> BracketStyle -> HsExpr GhcPs -> R () p_hsCmdTop :: BracketStyle -> HsCmdTop GhcPs -> R () exprPlacement :: HsExpr GhcPs -> Placement cmdTopPlacement :: HsCmdTop GhcPs -> Placement diff --git a/src/Ormolu/Printer/Operators.hs b/src/Ormolu/Printer/Operators.hs index 87a38e96c..9369a3273 100644 --- a/src/Ormolu/Printer/Operators.hs +++ b/src/Ormolu/Printer/Operators.hs @@ -60,18 +60,18 @@ compareOp (OpInfo _ mName1 FixityInfo {fiMinPrecedence = min1, fiMaxPrecedence = max1}) (OpInfo _ mName2 FixityInfo {fiMinPrecedence = min2, fiMaxPrecedence = max2}) = if - -- Only declare two precedence levels as equal when - -- * either both precedence levels are precise - -- (fiMinPrecedence == fiMaxPrecedence) and match - -- * or when the precedence levels are imprecise but when the - -- operator names match - | min1 == min2 - && max1 == max2 - && (min1 == max1 || sameSymbol) -> - Just EQ - | max1 < min2 -> Just LT - | max2 < min1 -> Just GT - | otherwise -> Nothing + -- Only declare two precedence levels as equal when + -- * either both precedence levels are precise + -- (fiMinPrecedence == fiMaxPrecedence) and match + -- * or when the precedence levels are imprecise but when the + -- operator names match + | min1 == min2 + && max1 == max2 + && (min1 == max1 || sameSymbol) -> + Just EQ + | max1 < min2 -> Just LT + | max2 < min1 -> Just GT + | otherwise -> Nothing where sameSymbol = case (mName1, mName2) of (Just n1, Just n2) -> n1 == n2