Pretty-printing of derived multi-parameter classes omits parentheseswip/T14289

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, 104 insertions, 0 deletions

diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index ecb11a08d6..9b21913c7f 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1102,7 +1102,9 @@ instance (SourceTextX pass, OutputableBndrId pass)
         -- This complexity is to distinguish between
         --    deriving Show
         --    deriving (Show)
+        pp_dct [a@(HsIB { hsib_body = L _ HsAppTy{}  })] = parens (ppr a)
         pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a)
+        pp_dct [a@(HsIB { hsib_body = L _ HsOpTy{}   })] = parens (ppr a)
         pp_dct [a] = ppr a
         pp_dct _   = parens (interpp'SP dct)
 
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index c008bd439a..48e2b80801 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -109,3 +109,4 @@ test('DumpRenamedAst',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast']
 test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
 test('T13747', normal, compile, [''])
 test('T14189',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
+test('T14189tc',   normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 1c2f2995d0..36aa050321 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -213,3 +213,11 @@ T13550:
 .PHONY: T13942
 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
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..9f26b637f0
--- /dev/null
+++ b/testsuite/tests/printer/T14289b.stdout
@@ -0,0 +1 @@
+Foo
\ No newline at end of file
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index a71d6e3534..43ab92baf6 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -50,3 +50,5 @@ 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'])