Hang expressions in RHS of (<-) in do blocks

Plus some refactoring.

data/examples/declaration/value/function/arrow/proc-do-complex-out.hs

@@ -24,8 +24,7 @@ foo
             d * b
           )
       if x `mod` y == 0 -- Basic condition
-      then
+        then case e of -- Only left case is relevant
-        case e of -- Only left case is relevant
           Left
             ( z,
               w
@@ -33,28 +32,25 @@ foo
               let v =
                     u -- Actually never used
                       ^ 2
-
                in ( returnA -<
                       -- Just do the calculation
                       (x + y * z)
                   )
-      else
+        else do
-        do
           let u = x -- Let bindings bind expressions, not commands
             -- Could pattern match directly on x
-          i <-
+          i <- case u of
-            case u of
+            0 -> (g . h -< u)
-              0 -> (g . h -< u)
+            n ->
-              n ->
+              ( ( h . g -<
-                ( ( h . g -<
+                    y -- First actual use of y
-                      y -- First actual use of y
-                  )
                 )
+              )
           returnA -< ()
           -- Sometimes execute effects
           if i > 0
-          then ma -< ()
+            then ma -< ()
-          else returnA -< ()
+            else returnA -< ()
           returnA -<
             ( i
                 + x

data/examples/declaration/value/function/arrow/proc-ifs-out.hs

@@ -4,10 +4,10 @@ foo f = proc a -> if a then f -< 0 else f -< 1
 
 bar f g = proc a ->
   if f a
-  then
+    then
-    f
+      f
-      . g -<
+        . g -<
-      a
+        a
-  else
+    else
-    g -<
+      g -<
-      b
+        b

data/examples/declaration/value/function/arrow/proc-lets-out.hs

@@ -9,5 +9,4 @@ bar f g = proc a ->
       j =
         g
           . h
-
    in id -< (h, j)

data/examples/declaration/value/function/do/expr.hs

@@ -8,4 +8,3 @@ quux = something $ do
   then x
   else y
   baz
-

data/examples/declaration/value/function/do/hang-rhs-arrow-out.hs

@@ -0,0 +1,9 @@
+foo = do
+  something <- case bar of
+    Foo -> return 1
+    Bar -> return 2
+  somethingElse <-
+    case boom of
+      Foo -> return 1
+      Bar -> return 2
+  quux something somethingElse

data/examples/declaration/value/function/do/hang-rhs-arrow.hs

@@ -0,0 +1,9 @@
+foo = do
+  something <- case bar of
+    Foo -> return 1
+    Bar -> return 2
+  somethingElse <-
+    case boom of
+      Foo -> return 1
+      Bar -> return 2
+  quux something somethingElse

src/Ormolu/Printer/Meat/Declaration/Value.hs

@@ -91,7 +91,7 @@ p_matchGroup'
   -> MatchGroupStyle            -- ^ Style of this group of equations
   -> MatchGroup GhcPs (Located body) -- ^ Match group
   -> R ()
-p_matchGroup' placer pretty style MG {..} = do
+p_matchGroup' placer render style MG {..} = do
   let ob = case style of
         Case -> id
         LambdaCase -> id
@@ -104,7 +104,7 @@ p_matchGroup' placer pretty style MG {..} = do
     p_Match m@Match {..} =
       p_match'
         placer
-        pretty
+        render
         (adjustMatchGroupStyle m style)
         (isInfixMatch m)
         (matchStrictness m)
@@ -153,7 +153,7 @@ p_match'
   -> [LPat GhcPs]               -- ^ Argument patterns
   -> GRHSs GhcPs (Located body) -- ^ Equations
   -> R ()
-p_match' placer pretty style isInfix strictness m_pats m_grhss = do
+p_match' placer render style isInfix strictness m_pats m_grhss = do
   -- NOTE Normally, since patterns may be placed in a multi-line layout, it
   -- is necessary to bump indentation for the pattern group so it's more
   -- indented than function name. This in turn means that indentation for
@@ -235,7 +235,7 @@ p_match' placer pretty style isInfix strictness m_pats m_grhss = do
               if isCase style && hasGuards
               then RightArrow
               else EqualSign
-        sep newline (located' (p_grhs' placer pretty groupStyle)) grhssGRHSs
+        sep newline (located' (p_grhs' placer render groupStyle)) grhssGRHSs
       p_where = do
         let whereIsEmpty = GHC.isEmptyLocalBindsPR (unLoc grhssLocalBinds)
         unless (GHC.eqEmptyLocalBinds (unLoc grhssLocalBinds)) $ do
@@ -258,7 +258,7 @@ p_grhs'
   -> GroupStyle
   -> GRHS GhcPs (Located body)
   -> R ()
-p_grhs' placer pretty style (GRHS NoExt guards body) =
+p_grhs' placer render style (GRHS NoExt guards body) =
   case guards of
     [] -> p_body
     xs -> do
@@ -282,7 +282,7 @@ p_grhs' placer pretty style (GRHS NoExt guards body) =
       case NE.nonEmpty guards of
         Nothing -> Nothing
         Just gs -> (Just . srcSpanEnd . getLoc . NE.last) gs
-    p_body = located body pretty
+    p_body = located body render
 p_grhs' _ _ _ (XGRHS NoExt) = notImplemented "XGRHS"
 
 p_hsCmd :: HsCmd GhcPs -> R ()
@@ -313,41 +313,17 @@ p_hsCmd = \case
     notImplemented "HsCmdApp"
   HsCmdLam NoExt mgroup -> p_matchGroup' cmdPlacement p_hsCmd Lambda mgroup
   HsCmdPar NoExt c -> parens N (located c p_hsCmd)
-  HsCmdCase NoExt e mgroup -> do
+  HsCmdCase NoExt e mgroup ->
-    txt "case"
+    p_case cmdPlacement p_hsCmd e mgroup
-    space
+  HsCmdIf NoExt _ if' then' else' ->
-    located e p_hsExpr
+    p_if cmdPlacement p_hsCmd if' then' else'
-    space
+  HsCmdLet NoExt localBinds c ->
-    txt "of"
+    p_let p_hsCmd localBinds c
-    breakpoint
-    inci (p_matchGroup' cmdPlacement p_hsCmd Case mgroup)
-  HsCmdIf NoExt _ if' then' else' -> do
-    txt "if"
-    space
-    located if' p_hsExpr
-    breakpoint
-    txt "then"
-    located then' $ \x -> do
-      breakpoint
-      inci (p_hsCmd x)
-    breakpoint
-    txt "else"
-    located else' $ \x -> do
-      breakpoint
-      inci (p_hsCmd x)
-  HsCmdLet NoExt localBinds c -> do
-    txt "let"
-    space
-    sitcc (located localBinds p_hsLocalBinds)
-    breakpoint
-    vlayout space (newline >> txt " ")
-    txt "in"
-    space
-    sitcc (located c p_hsCmd)
   HsCmdDo NoExt es -> do
     txt "do"
     newline
-    inci (located es (sitcc . sep newline (located' (sitcc . p_stmt' p_hsCmd))))
+    inci . located es $
+      sitcc . sep newline (located' (sitcc . p_stmt' cmdPlacement p_hsCmd))
   HsCmdWrap {} -> notImplemented "HsCmdWrap"
   XCmd {} -> notImplemented "XCmd"
 
@@ -357,23 +333,31 @@ p_hsCmdTop = \case
   XCmdTop {} -> notImplemented "XHsCmdTop"
 
 p_stmt :: Stmt GhcPs (LHsExpr GhcPs) -> R ()
-p_stmt = p_stmt' p_hsExpr
+p_stmt = p_stmt' exprPlacement p_hsExpr
 
 p_stmt'
   :: Data body
-  => (body -> R ())
+  => (body -> Placement)        -- ^ Placer
-  -> Stmt GhcPs (Located body)
+  -> (body -> R ())             -- ^ Render
+  -> Stmt GhcPs (Located body)  -- ^ Statement to render
   -> R ()
-p_stmt' pretty = \case
+p_stmt' placer render = \case
-  LastStmt NoExt body _ _ -> located body pretty
+  LastStmt NoExt body _ _ -> located body render
   BindStmt NoExt l f _ _ -> do
     located l p_pat
     space
     txt "<-"
-    breakpoint
+    let placement =
-    inci (located f pretty)
+          case f of
+            L l' x ->
+              if isOneLineSpan
+                   (mkSrcSpan (srcSpanEnd (getLoc l)) (srcSpanStart l'))
+                then placer x
+                else Normal
+    switchLayout [getLoc l, getLoc f] $
+      placeHanging placement (located f render)
   ApplicativeStmt {} -> notImplemented "ApplicativeStmt" -- generated by renamer
-  BodyStmt NoExt body _ _ -> located body pretty
+  BodyStmt NoExt body _ _ -> located body render
   LetStmt NoExt binds -> do
     txt "let"
     space
@@ -384,7 +368,7 @@ p_stmt' pretty = \case
     -- here would be redundant.
     notImplemented "ParStmt"
   TransStmt {..} -> do
-    -- NOTE 'TransStmt' only needs to account for pretty printing itself,
+    -- NOTE 'TransStmt' only needs to account for render printing itself,
     -- since pretty printing of relevant statements (e.g., in 'trS_stmts')
     -- is handled through 'gatherStmt'.
     case (trS_form, trS_by) of
@@ -415,7 +399,7 @@ p_stmt' pretty = \case
   RecStmt {..} -> do
     txt "rec"
     space
-    sitcc $ sepSemi (located' (p_stmt' pretty)) recS_stmts
+    sitcc $ sepSemi (located' (p_stmt' placer render)) recS_stmts
   XStmtLR {} -> notImplemented "XStmtLR"
 
 gatherStmt :: ExprLStmt GhcPs -> [[ExprLStmt GhcPs]]
@@ -581,45 +565,24 @@ p_hsExpr' s = \case
              sep (comma >> breakpoint) (sitcc . located' p_hsTupArg) args
   ExplicitSum NoExt tag arity e ->
     p_unboxedSum N tag arity (located e p_hsExpr)
-  HsCase NoExt e mgroup -> do
+  HsCase NoExt e mgroup ->
-    txt "case"
+    p_case exprPlacement p_hsExpr e mgroup
-    space
+  HsIf NoExt _ if' then' else' ->
-    located e p_hsExpr
+    p_if exprPlacement p_hsExpr if' then' else'
-    space
-    txt "of"
-    breakpoint
-    inci (p_matchGroup Case mgroup)
-  HsIf NoExt _ if' then' else' -> do
-    txt "if"
-    space
-    located if' p_hsExpr
-    breakpoint
-    inci $ do
-      txt "then"
-      located then' $ \x ->
-        placeHanging (exprPlacement x) (p_hsExpr x)
-      breakpoint
-      txt "else"
-      located else' $ \x ->
-        placeHanging (exprPlacement x) (p_hsExpr x)
   HsMultiIf NoExt guards -> do
     txt "if"
     breakpoint
     inci . sitcc $ sep newline (located' (p_grhs RightArrow)) guards
-  HsLet NoExt localBinds e -> sitcc $ do
+  HsLet NoExt localBinds e ->
-    txt "let"
+    p_let p_hsExpr localBinds e
-    space
-    dontUseBraces $ sitcc (located localBinds p_hsLocalBinds)
-    vlayout space (newline >> txt " ")
-    txt "in"
-    space
-    sitcc (located e p_hsExpr)
   HsDo NoExt ctx es -> do
     let doBody header = do
           txt header
           breakpoint
           ub <- layoutToBraces <$> getLayout
-          inci $ sepSemi (located' (ub . p_stmt' (p_hsExpr' S))) (unLoc es)
+          inci $ sepSemi
+            (located' (ub . p_stmt' exprPlacement (p_hsExpr' S)))
+            (unLoc es)
         compBody = brackets N $ located es $ \xs -> do
           let p_parBody = sep
                 (breakpoint >> txt "| ")
@@ -816,6 +779,59 @@ p_patSynBind PSB {..} = do
       inci rhs
 p_patSynBind (XPatSynBind NoExt) = notImplemented "XPatSynBind"
 
+p_case
+  :: Data body
+  => (body -> Placement)        -- ^ Placer
+  -> (body -> R ())             -- ^ Render
+  -> LHsExpr GhcPs              -- ^ Expression
+  -> (MatchGroup GhcPs (Located body)) -- ^ Match group
+  -> R ()
+p_case placer render e mgroup = do
+  txt "case"
+  space
+  located e p_hsExpr
+  space
+  txt "of"
+  breakpoint
+  inci (p_matchGroup' placer render Case mgroup)
+
+p_if
+  :: Data body
+  => (body -> Placement)        -- ^ Placer
+  -> (body -> R ())             -- ^ Render
+  -> LHsExpr GhcPs              -- ^ If
+  -> Located body               -- ^ Then
+  -> Located body               -- ^ Else
+  -> R ()
+p_if placer render if' then' else' = do
+  txt "if"
+  space
+  located if' p_hsExpr
+  breakpoint
+  inci $ do
+    txt "then"
+    located then' $ \x ->
+      placeHanging (placer x) (render x)
+    breakpoint
+    txt "else"
+    located else' $ \x ->
+      placeHanging (placer x) (render x)
+
+p_let
+  :: Data body
+  => (body -> R ())             -- ^ Render
+  -> Located (HsLocalBindsLR GhcPs GhcPs)
+  -> Located body
+  -> R ()
+p_let render localBinds e = sitcc $ do
+  txt "let"
+  space
+  dontUseBraces $ sitcc (located localBinds p_hsLocalBinds)
+  vlayout space (newline >> txt " ")
+  txt "in"
+  space
+  sitcc (located e render)
+
 p_pat :: Pat GhcPs -> R ()
 p_pat = \case
   WildPat NoExt -> txt "_"