Pretty-printing of derived multi-parameter classes omits parentheses

Summary:
Pretty printing a splice with an HsAppType in the deriving clause, such as

    $([d| data Foo a = Foo a deriving (C a) |])

would omit the parens.

Test Plan: ./validate

Reviewers: RyanGlScott, austin, bgamari

Subscribers: rwbarton, thomie

GHC Trac Issues: #14289

Differential Revision: https://phabricator.haskell.org/D4056

8 files changed, 177 insertions, 0 deletions

diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 4565e83b4d..17fc65215f 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -214,6 +214,18 @@ T13550:
 T13942:
 	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13942.hs
 
+.PHONY: T14289
+T14289:
+	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289.hs
+
+.PHONY: T14289b
+T14289b:
+	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289b.hs
+
+.PHONY: T14289c
+T14289c:
+	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14289c.hs
+
 .PHONY: T14306
 T14306:
 	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs
diff --git a/testsuite/tests/printer/T14289.hs b/testsuite/tests/printer/T14289.hs
new file mode 100644
index 0000000000..04b9176c69
--- /dev/null
+++ b/testsuite/tests/printer/T14289.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+import Language.Haskell.TH
+
+class C a b
+
+$([d| data Foo a = Foo a deriving (C a) |])
+
+{-
+
+Note: to debug
+
+~/inplace/bin/ghc-stage2 --interactive
+load the following
+----------------------------------------
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+import Language.Haskell.TH
+
+class C a b
+
+main :: IO ()
+main = putStrLn $([d| data Foo a = Foo a deriving (C a) |] >>= stringE . show)
+
+----------------------------------------
+
+-}
diff --git a/testsuite/tests/printer/T14289.stdout b/testsuite/tests/printer/T14289.stdout
new file mode 100644
index 0000000000..3f0754adca
--- /dev/null
+++ b/testsuite/tests/printer/T14289.stdout
@@ -0,0 +1,16 @@
+T14289.hs:10:3-42: Splicing declarations
+    [d| data Foo a
+          = Foo a
+          deriving (C a) |]
+  ======>
+    data Foo a
+      = Foo a
+      deriving (C a)
+T14289.ppr.hs:(7,3)-(9,25): Splicing declarations
+    [d| data Foo a
+          = Foo a
+          deriving (C a) |]
+  ======>
+    data Foo a
+      = Foo a
+      deriving (C a)
diff --git a/testsuite/tests/printer/T14289b.hs b/testsuite/tests/printer/T14289b.hs
new file mode 100644
index 0000000000..3ff39805d6
--- /dev/null
+++ b/testsuite/tests/printer/T14289b.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+import Language.Haskell.TH
+
+class (a `C` b) c
+
+$([d| data Foo a = Foo a deriving (y `C` z) |])
+
+{-
+
+Note: to debug
+
+~/inplace/bin/ghc-stage2 --interactive
+load the following
+----------------------------------------
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+import Language.Haskell.TH
+
+class (a `C` b) c
+
+main :: IO ()
+main
+  = putStrLn $([d| data Foo a = Foo a deriving (y `C` z) |] >>= stringE . show)
+
+----------------------------------------
+Bceomes
+
+
+[DataD [] Foo_0 [PlainTV a_2] Nothing
+  [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]]
+  [DerivClause Nothing
+      [AppT (AppT (ConT Main.C) (VarT y_6989586621679027885))
+            (VarT z_6989586621679027886)]]]
+
+-}
diff --git a/testsuite/tests/printer/T14289b.stdout b/testsuite/tests/printer/T14289b.stdout
new file mode 100644
index 0000000000..5d4b248ac3
--- /dev/null
+++ b/testsuite/tests/printer/T14289b.stdout
@@ -0,0 +1,16 @@
+T14289b.hs:11:3-46: Splicing declarations
+    [d| data Foo a
+          = Foo a
+          deriving (y `C` z) |]
+  ======>
+    data Foo a
+      = Foo a
+      deriving (C y z)
+T14289b.ppr.hs:(8,3)-(10,29): Splicing declarations
+    [d| data Foo a
+          = Foo a
+          deriving (y `C` z) |]
+  ======>
+    data Foo a
+      = Foo a
+      deriving (C y z)
diff --git a/testsuite/tests/printer/T14289c.hs b/testsuite/tests/printer/T14289c.hs
new file mode 100644
index 0000000000..6e58df1a54
--- /dev/null
+++ b/testsuite/tests/printer/T14289c.hs
@@ -0,0 +1,40 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeOperators #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+import Language.Haskell.TH
+
+$([d| data Foo a = Foo a deriving (a ~ a) |])
+
+{-
+
+Note: to debug
+
+~/inplace/bin/ghc-stage2 --interactive
+load the following
+----------------------------------------
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+
+import Language.Haskell.TH
+
+class (a `C` b) c
+
+main :: IO ()
+main
+  = putStrLn $([d| data Foo a = Foo a deriving (a ~ a) |] >>= stringE . show)
+
+----------------------------------------
+Becomes
+
+[DataD [] Foo_0 [PlainTV a_2] Nothing
+  [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]]
+  [DerivClause Nothing
+    [AppT (AppT EqualityT (VarT a_2))
+          (VarT a_2)]]]
+
+
+-}
diff --git a/testsuite/tests/printer/T14289c.stdout b/testsuite/tests/printer/T14289c.stdout
new file mode 100644
index 0000000000..d200f99a2b
--- /dev/null
+++ b/testsuite/tests/printer/T14289c.stdout
@@ -0,0 +1,16 @@
+T14289c.hs:9:3-44: Splicing declarations
+    [d| data Foo a
+          = Foo a
+          deriving (a ~ a) |]
+  ======>
+    data Foo a
+      = Foo a
+      deriving (a ~ a)
+T14289c.ppr.hs:(7,3)-(9,27): Splicing declarations
+    [d| data Foo a
+          = Foo a
+          deriving (a ~ a) |]
+  ======>
+    data Foo a
+      = Foo a
+      deriving (a ~ a)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 9a1170ec0a..7dda6b36fa 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -50,4 +50,7 @@ test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T1319
 test('T13050p', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13050p'])
 test('T13550', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13550'])
 test('T13942', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13942'])
+test('T14289', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14289'])
+test('T14289b', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14289b'])
+test('T14289c', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14289c'])
 test('T14306', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T14306'])