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`)

13 files changed, 67 insertions, 26 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 42d32487c8..d9ae558c15 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/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
diff --git a/testsuite/tests/quotes/T20893.hs b/testsuite/tests/quotes/T20893.hs
index 90f1efb331..079a23166c 100644
--- a/testsuite/tests/quotes/T20893.hs
+++ b/testsuite/tests/quotes/T20893.hs
@@ -1,5 +1,7 @@
 -- #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
diff --git a/testsuite/tests/quotes/T20893.stdout b/testsuite/tests/quotes/T20893.stdout
index c08abdd03d..222f0f8d49 100644
--- a/testsuite/tests/quotes/T20893.stdout
+++ b/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)}
diff --git a/testsuite/tests/quotes/TH_ppr1.stdout b/testsuite/tests/quotes/TH_ppr1.stdout
index 6c18e3fa2b..f6b89ec83e 100644
--- a/testsuite/tests/quotes/TH_ppr1.stdout
+++ b/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)
diff --git a/testsuite/tests/th/T10891.stderr b/testsuite/tests/th/T10891.stderr
index 6b382e61d9..a73b663f6f 100644
--- a/testsuite/tests/th/T10891.stderr
+++ b/testsuite/tests/th/T10891.stderr
@@ -1,10 +1,10 @@
 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
diff --git a/testsuite/tests/th/T11797.stderr b/testsuite/tests/th/T11797.stderr
index b978e63aff..c46f61d852 100644
--- a/testsuite/tests/th/T11797.stderr
+++ b/testsuite/tests/th/T11797.stderr
@@ -1,2 +1,2 @@
 class Foo_0 a_1
-    where meth_2 :: a_1 -> b_3 -> a_1
+    where {meth_2 :: a_1 -> b_3 -> a_1}
diff --git a/testsuite/tests/th/T14888.stderr b/testsuite/tests/th/T14888.stderr
index f58d0c8b45..fe77220edc 100644
--- a/testsuite/tests/th/T14888.stderr
+++ b/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)"
diff --git a/testsuite/tests/th/T4135.stderr b/testsuite/tests/th/T4135.stderr
index 3a4c6084d4..a8cdcd8965 100644
--- a/testsuite/tests/th/T4135.stderr
+++ b/testsuite/tests/th/T4135.stderr
@@ -1,2 +1,2 @@
 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}
diff --git a/testsuite/tests/th/T7064.stdout b/testsuite/tests/th/T7064.stdout
index d9790f79e9..b5f8c47103 100644
--- a/testsuite/tests/th/T7064.stdout
+++ b/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 #-}
diff --git a/testsuite/tests/th/T9064.stderr b/testsuite/tests/th/T9064.stderr
index c7f3df187c..1e027d35bf 100644
--- a/testsuite/tests/th/T9064.stderr
+++ b/testsuite/tests/th/T9064.stderr
@@ -1,4 +1,4 @@
 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
diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr
index 1984d85075..c9b295ec83 100644
--- a/testsuite/tests/th/TH_reifyDecl1.stderr
+++ b/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
diff --git a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr b/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
index 673f09e2e0..be0bf5ad86 100644
--- a/testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
+++ b/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 :: *)
diff --git a/testsuite/tests/th/TH_repUnboxedTuples.stderr b/testsuite/tests/th/TH_repUnboxedTuples.stderr
index b8bedac854..1d58620d34 100644
--- a/testsuite/tests/th/TH_repUnboxedTuples.stderr
+++ b/testsuite/tests/th/TH_repUnboxedTuples.stderr
@@ -1,5 +1,5 @@
 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 #)}