summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs16
-rw-r--r--testsuite/tests/quotes/T20893.hs22
-rw-r--r--testsuite/tests/quotes/T20893.stdout11
-rw-r--r--testsuite/tests/quotes/TH_ppr1.stdout2
-rw-r--r--testsuite/tests/th/T10891.stderr10
-rw-r--r--testsuite/tests/th/T11797.stderr2
-rw-r--r--testsuite/tests/th/T14888.stderr4
-rw-r--r--testsuite/tests/th/T4135.stderr2
-rw-r--r--testsuite/tests/th/T7064.stdout4
-rw-r--r--testsuite/tests/th/T9064.stderr4
-rw-r--r--testsuite/tests/th/TH_reifyDecl1.stderr8
-rw-r--r--testsuite/tests/th/TH_reifyExplicitForAllFams.stderr2
-rw-r--r--testsuite/tests/th/TH_repUnboxedTuples.stderr6
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 #)}
View Lorry Controller Status