Use braces in TH LambdaCase and where clauses

This patch ensures that the pretty printer formats LambdaCase and where
clauses using braces (instead of layout) to remain consistent with the
formatting of other statements (like `do` and `case`)

libraries/template-haskell/Language/Haskell/TH/Ppr.hs

@@ -155,7 +155,7 @@ pprExp i (LamE [] e) = pprExp i e -- #13856
 pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps)
                                            <+> text "->" <+> ppr e
 pprExp i (LamCaseE ms) = parensIf (i > noPrec)
-                       $ text "\\case" $$ nest nestDepth (ppr ms)
+                       $ text "\\case" $$ braces (semiSep ms)
 pprExp i (TupE es)
   | [Just e] <- es
   = pprExp i (ConE (tupleDataName 1) `AppE` e)
@@ -938,7 +938,7 @@ instance Ppr Range where
 ------------------------------
 where_clause :: [Dec] -> Doc
 where_clause [] = empty
-where_clause ds = nest nestDepth $ text "where" <+> vcat (map (ppr_dec False) ds)
+where_clause ds = nest nestDepth $ text "where" <+> braces (semiSepWith (ppr_dec False) ds)
 
 showtextl :: Show a => a -> Doc
 showtextl = text . map toLower . show
@@ -960,6 +960,11 @@ instance Ppr Loc where
            , text "-"
            , parens $ int end_ln <> comma <> int end_col ]
 
+-- Takes a separator and a pretty-printing function and prints a list of things
+-- separated by the separator followed by space.
+sepWith :: Doc -> (a -> Doc) -> [a] -> Doc
+sepWith sepDoc pprFun = sep . punctuate sepDoc . map pprFun
+
 -- Takes a list of printable things and prints them separated by commas followed
 -- by space.
 commaSep :: Ppr a => [a] -> Doc
@@ -968,13 +973,18 @@ commaSep = commaSepWith ppr
 -- Takes a list of things and prints them with the given pretty-printing
 -- function, separated by commas followed by space.
 commaSepWith :: (a -> Doc) -> [a] -> Doc
-commaSepWith pprFun = sep . punctuate comma . map pprFun
+commaSepWith pprFun = sepWith comma pprFun
 
 -- Takes a list of printable things and prints them separated by semicolons
 -- followed by space.
 semiSep :: Ppr a => [a] -> Doc
 semiSep = sep . punctuate semi . map ppr
 
+-- Takes a list of things and prints them with the given pretty-printing
+-- function, separated by semicolons followed by space.
+semiSepWith :: (a -> Doc) -> [a] -> Doc
+semiSepWith pprFun = sepWith semi pprFun
+
 -- Prints out the series of vertical bars that wraps an expression or pattern
 -- used in an unboxed sum.
 unboxedSumBars :: Doc -> SumAlt -> SumArity -> Doc

testsuite/tests/quotes/T20893.hs

 -- #20893
 
+{-# LANGUAGE LambdaCase #-}
+
 module Main where
 
 import Language.Haskell.TH
@@ -8,6 +10,8 @@ import Language.Haskell.TH.Ppr
 main = do
   runQ t1 >>= p
   runQ t2 >>= p
+  runQ t3 >>= p
+  runQ t4 >>= p
 
 t1 = [d| main = do { case 0 of { 0 -> 1 }; putStrLn "pass" } |]
 
@@ -26,4 +30,22 @@ t2 = [d|
          putStrLn (show day) ++ " is " (show num)
       |]
 
+t3 = [d|
+      main = do
+         let color = "red"
+         let id = 1
+         print_color (color, id)
+       where print_color (c, i) = putStrLn (c ++ " is " ++ (show i))
+      |]
+
+t4 = [d|
+      main = do
+         let colors = ["red", "green", "blue"]
+         let ids = map (\case
+                           "red" -> 0
+                           "green" -> 1
+                           "blue" -> 2) colors
+         putStrLn (show ids)
+      |]
+
 p = putStrLn . pprint

testsuite/tests/quotes/T20893.stdout

@@ -11,4 +11,13 @@ main_0 = do {let {day_1 = "mon"};
                            "sat" -> 6;
                            "sun" -> 7;
                            _ -> 8}};
-             System.IO.putStrLn (GHC.Show.show day_1) GHC.Base.++ " is " (GHC.Show.show num_2)}
\ No newline at end of file
+             System.IO.putStrLn (GHC.Show.show day_1) GHC.Base.++ " is " (GHC.Show.show num_2)}
+main_0 = do {let {color_1 = "red"};
+             let {id_2 = 1};
+             print_color_3 (color_1, id_2)}
+    where {print_color_3 (c_4,
+                          i_5) = System.IO.putStrLn (c_4 GHC.Base.++ (" is " GHC.Base.++ GHC.Show.show i_5))}
+main_0 = do {let {colors_1 = ["red", "green", "blue"]};
+             let {ids_2 = GHC.Base.map (\case
+                                        {"red" -> 0; "green" -> 1; "blue" -> 2}) colors_1};
+             System.IO.putStrLn (GHC.Show.show ids_2)}

testsuite/tests/quotes/TH_ppr1.stdout

@@ -7,7 +7,7 @@ Main.u1 GHC.Types.: Main.u2
 \((GHC.Types.:) x_0 xs_1) -> x_0
 \(x_0 GHC.Types.: xs_1) -> x_0
 class Foo_0 a_1 b_2
-    where foo_3 :: a_1 -> b_2
+    where {foo_3 :: a_1 -> b_2}
 \x_0 -> (x_0, 1 `x_0` 2)
 \(+_0) -> ((+_0), 1 +_0 2)
 (Main.f, 1 `Main.f` 2)

testsuite/tests/th/T10891.stderr

 class T10891.C (a_0 :: *)
-    where T10891.f :: a_0 -> GHC.Types.Int
+    where {T10891.f :: a_0 -> GHC.Types.Int}
 class T10891.C' (a_0 :: *)
-    where type T10891.F (a_0 :: *) :: *
-          type T10891.F a_0 = a_0
-          T10891.f' :: a_0 -> GHC.Types.Int
+    where {type T10891.F (a_0 :: *) :: *;
+           type T10891.F a_0 = a_0;
+           T10891.f' :: a_0 -> GHC.Types.Int}
 instance T10891.C' GHC.Types.Int
 class T10891.C'' (a_0 :: *)
-    where data T10891.Fd (a_0 :: *) :: *
+    where {data T10891.Fd (a_0 :: *) :: *}
 instance T10891.C'' GHC.Types.Int

testsuite/tests/th/T11797.stderr

 class Foo_0 a_1
-    where meth_2 :: a_1 -> b_3 -> a_1
+    where {meth_2 :: a_1 -> b_3 -> a_1}

testsuite/tests/th/T14888.stderr

@@ -5,6 +5,6 @@ T14888.hs:18:22-60: Splicing expression
     reify ''Functor' >>= stringE . pprint
   ======>
     "class T14888.Functor' (f_0 :: * -> *)
-    where T14888.fmap' :: forall (a_1 :: *) (b_2 :: *) .
-                          (a_1 -> b_2) -> f_0 a_1 -> f_0 b_2
+    where {T14888.fmap' :: forall (a_1 :: *) (b_2 :: *) .
+                           (a_1 -> b_2) -> f_0 a_1 -> f_0 b_2}
 instance T14888.Functor' ((->) r_3)"

testsuite/tests/th/T4135.stderr

 instance Bug.C (GHC.Maybe.Maybe a_0)
-    where type Bug.T (GHC.Maybe.Maybe a_0) = GHC.Types.Char
+    where {type Bug.T (GHC.Maybe.Maybe a_0) = GHC.Types.Char}

testsuite/tests/th/T7064.stdout

@@ -13,8 +13,8 @@ g3_0 x_1 = 3
                              GHC.Types.Int -> GHC.Types.Int #-}
 data T_0 a_1 = T_2 a_1
 instance GHC.Classes.Eq a_0 => GHC.Classes.Eq (T_1 a_0)
-    where {-# SPECIALISE instance GHC.Classes.Eq (T_1 GHC.Types.Int) #-}
-          (GHC.Classes.==) (T_2 x_3) (T_2 y_4) = x_3 GHC.Classes.== y_4
+    where {{-# SPECIALISE instance GHC.Classes.Eq (T_1 GHC.Types.Int) #-};
+           (GHC.Classes.==) (T_2 x_3) (T_2 y_4) = x_3 GHC.Classes.== y_4}
 {-# RULES "rule1"
     GHC.Real.fromIntegral
     = GHC.Base.id :: a_0 -> a_0 #-}

testsuite/tests/th/T9064.stderr

 class T9064.C (a_0 :: *)
-    where T9064.foo :: a_0 -> GHC.Base.String
-          default T9064.foo :: GHC.Show.Show a_0 => a_0 -> GHC.Base.String
+    where {T9064.foo :: a_0 -> GHC.Base.String;
+           default T9064.foo :: GHC.Show.Show a_0 => a_0 -> GHC.Base.String}
 instance T9064.C T9064.Bar

testsuite/tests/th/TH_reifyDecl1.stderr

@@ -14,13 +14,13 @@ Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall {k_0 :: *} (a_
 Class op from TH_reifyDecl1.C1: TH_reifyDecl1.m1 :: forall (a_0 :: *) . TH_reifyDecl1.C1 a_0 =>
                                                     a_0 -> GHC.Types.Int
 class TH_reifyDecl1.C1 (a_0 :: *)
-    where TH_reifyDecl1.m1 :: a_0 -> GHC.Types.Int
+    where {TH_reifyDecl1.m1 :: a_0 -> GHC.Types.Int}
 class TH_reifyDecl1.C2 (a_0 :: *)
-    where TH_reifyDecl1.m2 :: a_0 -> GHC.Types.Int
+    where {TH_reifyDecl1.m2 :: a_0 -> GHC.Types.Int}
 instance TH_reifyDecl1.C2 GHC.Types.Int
 class TH_reifyDecl1.C3 (a_0 :: k_1)
-    where type TH_reifyDecl1.AT1 (a_0 :: k_1) :: *
-          data TH_reifyDecl1.AT2 (a_0 :: k_1) :: *
+    where {type TH_reifyDecl1.AT1 (a_0 :: k_1) :: *;
+           data TH_reifyDecl1.AT2 (a_0 :: k_1) :: *}
 instance TH_reifyDecl1.C3 GHC.Types.Int
 type family TH_reifyDecl1.AT1 (a_0 :: k_1) :: *
 type instance TH_reifyDecl1.AT1 GHC.Types.Int = GHC.Types.Bool

testsuite/tests/th/TH_reifyExplicitForAllFams.stderr

@@ -2,7 +2,7 @@ data family TH_reifyExplicitForAllFams.F (a_0 :: *) :: *
 data instance forall (a_1 :: *). TH_reifyExplicitForAllFams.F (GHC.Maybe.Maybe a_1)
     = TH_reifyExplicitForAllFams.MkF a_1
 class TH_reifyExplicitForAllFams.C (a_0 :: *)
-    where type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
+    where {type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *}
 instance TH_reifyExplicitForAllFams.C ([a_2])
 type family TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
 type instance forall (a_2 :: *)

testsuite/tests/th/TH_repUnboxedTuples.stderr

 CaseE (UnboxedTupE [Just (LitE (CharL 'b')),Just (ConE GHC.Types.False)]) [Match (UnboxedTupP [LitP (CharL 'a'),ConP GHC.Types.True [] []]) (NormalB (UnboxedTupE [Just (LitE (StringL "One")),Just (LitE (IntegerL 1))])) [],Match (UnboxedTupP [LitP (CharL 'b'),ConP GHC.Types.False [] []]) (NormalB (UnboxedTupE [Just (LitE (StringL "Two")),Just (LitE (IntegerL 2))])) [],Match (UnboxedTupP [WildP,WildP]) (NormalB (UnboxedTupE [Just (LitE (StringL "Three")),Just (LitE (IntegerL 3))])) []]
 case (# 'b', GHC.Types.False #) of
-    (# 'a', GHC.Types.True #) -> (# "One", 1 #)
-    (# 'b', GHC.Types.False #) -> (# "Two", 2 #)
-    (# _, _ #) -> (# "Three", 3 #)
+{(# 'a', GHC.Types.True #) -> (# "One", 1 #);
+ (# 'b', GHC.Types.False #) -> (# "Two", 2 #);
+ (# _, _ #) -> (# "Three", 3 #)}