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

11 files changed, 219 insertions, 6 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index bffb2028c3..4336243e91 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1330,14 +1330,38 @@ mk_apps head_ty (ty:tys) =
      ; p_ty      <- add_parens ty
      ; mk_apps (HsAppTy head_ty' p_ty) tys }
   where
-    add_parens t@(L _ HsAppTy{}) = returnL (HsParTy t)
-    add_parens t@(L _ HsFunTy{}) = returnL (HsParTy t)
-    add_parens t                 = return t
+    -- See Note [Adding parens for splices]
+    add_parens t
+      | isCompoundHsType t = returnL (HsParTy t)
+      | otherwise          = return t
 
 wrap_apps  :: LHsType GhcPs -> CvtM (LHsType GhcPs)
 wrap_apps t@(L _ HsAppTy {}) = returnL (HsParTy t)
 wrap_apps t                  = return t
 
+-- ---------------------------------------------------------------------
+-- Note [Adding parens for splices]
+{-
+The hsSyn representation of parsed source explicitly contains all the original
+parens, as written in the source.
+
+When a Template Haskell (TH) splice is evaluated, the original splice is first
+renamed and type checked and then finally converted to core in DsMeta. This core
+is then run in the TH engine, and the result comes back as a TH AST.
+
+In the process, all parens are stripped out, as they are not needed.
+
+This Convert module then converts the TH AST back to hsSyn AST.
+
+In order to pretty-print this hsSyn AST, parens need to be adde back at certain
+points so that the code is readable with its original meaning.
+
+So scattered through Convert.hs are various points where parens are added.
+
+See (among other closed issued) https://ghc.haskell.org/trac/ghc/ticket/14289
+-}
+-- ---------------------------------------------------------------------
+
 -- | Constructs an arrow type with a specified return type
 mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)
 mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 35fccd3396..55d43fd058 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1106,8 +1106,9 @@ instance (SourceTextX pass, OutputableBndrId pass)
         -- This complexity is to distinguish between
         --    deriving Show
         --    deriving (Show)
-        pp_dct [a@(HsIB { hsib_body = L _ HsAppsTy{} })] = parens (ppr a)
-        pp_dct [a] = ppr a
+        pp_dct [a@(HsIB { hsib_body = ty })]
+          | isCompoundHsType ty = parens (ppr a)
+          | otherwise           = ppr a
         pp_dct _   = parens (interpp'SP dct)
 
 data NewOrData
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index e9fc71bdd7..f5b4149f99 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -65,7 +65,8 @@ module HsTypes (
 
         -- Printing
         pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
-        pprHsContext, pprHsContextNoArrow, pprHsContextMaybe
+        pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
+        isCompoundHsType
     ) where
 
 import GhcPrelude
@@ -1365,3 +1366,13 @@ ppr_app_ty (HsAppPrefix ty) = ppr_mono_lty ty
 ppr_tylit :: HsTyLit -> SDoc
 ppr_tylit (HsNumTy _ i) = integer i
 ppr_tylit (HsStrTy _ s) = text (show s)
+
+
+-- | Return True for compound types that will need parens.
+isCompoundHsType :: LHsType pass -> Bool
+isCompoundHsType (L _ HsAppTy{} ) = True
+isCompoundHsType (L _ HsAppsTy{}) = True
+isCompoundHsType (L _ HsEqTy{}  ) = True
+isCompoundHsType (L _ HsFunTy{} ) = True
+isCompoundHsType (L _ HsOpTy{}  ) = True
+isCompoundHsType _                = False
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'])