TH-spliced class instances are pretty-printed incorrectly post-#3384

Summary:
The HsSyn prettyprinter tests patch 499e43824bda967546ebf95ee33ec1f84a114a7c
broke the pretty-printing of Template Haskell-spliced class instances.

Test Plan: ./validate

Reviewers: RyanGlScott, austin, goldfire, bgamari

Reviewed By: RyanGlScott, bgamari

Subscribers: thomie

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

7 files changed, 134 insertions, 33 deletions

diff --git a/testsuite/tests/ghci/scripts/T10508.stderr b/testsuite/tests/ghci/scripts/T10508.stderr
index 86cdc82e92..365bf9fcae 100644
--- a/testsuite/tests/ghci/scripts/T10508.stderr
+++ b/testsuite/tests/ghci/scripts/T10508.stderr
@@ -4,7 +4,7 @@
       Expected type: IO Prelude.String
         Actual type: IO (a0 -> a0)
     • In the expression: return id
-      In the second argument of ‘(.)’, namely ‘\ _ -> return id’
+      In the second argument of ‘(.)’, namely ‘(\ _ -> return id)’
       In the expression:
           (.)
             (GHC.GHCi.ghciStepIO :: IO Prelude.String -> IO Prelude.String)
diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
index a92ab4cb66..eee11ab51f 100644
--- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
+++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr
@@ -29,14 +29,16 @@
         (HsVar 
          ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})}))))) 
      ({ <no location info> }
-      (HsApp 
-       ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
+      (HsPar 
        ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "Peano"))))))) 
+        (HsApp 
+         ({ <no location info> }
+          (HsConLikeOut 
+           ({abstract:ConLike}))) 
+         ({ <no location info> }
+          (HsLit 
+           (HsStringPrim 
+            (NoSourceText) "Peano"))))))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (main:DumpTypecheckedAst.$tc'Zero{v rFM} [lidx] :: ghc-prim:GHC.Types.TyCon{tc 61Z})} 
@@ -65,14 +67,16 @@
         (HsVar 
          ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})}))))) 
      ({ <no location info> }
-      (HsApp 
+      (HsPar 
        ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
-       ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "'Zero"))))))) 
+        (HsApp 
+         ({ <no location info> }
+          (HsConLikeOut 
+           ({abstract:ConLike}))) 
+         ({ <no location info> }
+          (HsLit 
+           (HsStringPrim 
+            (NoSourceText) "'Zero"))))))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (main:DumpTypecheckedAst.$tc'Succ{v rH3} [lidx] :: ghc-prim:GHC.Types.TyCon{tc 61Z})} 
@@ -101,14 +105,16 @@
         (HsVar 
          ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})}))))) 
      ({ <no location info> }
-      (HsApp 
-       ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
+      (HsPar 
        ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "'Succ"))))))) 
+        (HsApp 
+         ({ <no location info> }
+          (HsConLikeOut 
+           ({abstract:ConLike}))) 
+         ({ <no location info> }
+          (HsLit 
+           (HsStringPrim 
+            (NoSourceText) "'Succ"))))))))) 
    (False))),
  ({ <no location info> }
   (VarBind {Var: (main:DumpTypecheckedAst.$trModule{v rHO} [lidx] :: ghc-prim:GHC.Types.Module{tc 625})} 
@@ -120,6 +126,19 @@
         (HsConLikeOut 
          ({abstract:ConLike}))) 
        ({ <no location info> }
+        (HsPar 
+         ({ <no location info> }
+          (HsApp 
+           ({ <no location info> }
+            (HsConLikeOut 
+             ({abstract:ConLike}))) 
+           ({ <no location info> }
+            (HsLit 
+             (HsStringPrim 
+              (NoSourceText) "main"))))))))) 
+     ({ <no location info> }
+      (HsPar 
+       ({ <no location info> }
         (HsApp 
          ({ <no location info> }
           (HsConLikeOut 
@@ -127,16 +146,7 @@
          ({ <no location info> }
           (HsLit 
            (HsStringPrim 
-            (NoSourceText) "main"))))))) 
-     ({ <no location info> }
-      (HsApp 
-       ({ <no location info> }
-        (HsConLikeOut 
-         ({abstract:ConLike}))) 
-       ({ <no location info> }
-        (HsLit 
-         (HsStringPrim 
-          (NoSourceText) "DumpTypecheckedAst"))))))) 
+            (NoSourceText) "DumpTypecheckedAst"))))))))) 
    (False))),
  ({ DumpTypecheckedAst.hs:11:1-23 }
   (AbsBinds 
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 7a6bbc5de4..bc2a4ed998 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -197,3 +197,7 @@ ppr047:
 .PHONY: ppr048
 ppr048:
 	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" Ppr048.hs
+
+.PHONY: T13199
+T13199:
+	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T13199.hs
diff --git a/testsuite/tests/printer/T13199.hs b/testsuite/tests/printer/T13199.hs
new file mode 100644
index 0000000000..0bc36f3730
--- /dev/null
+++ b/testsuite/tests/printer/T13199.hs
@@ -0,0 +1,38 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
+module Bug where
+
+class C a b c
+data B a b = B { aa :: a, bb :: b }
+
+-- Types requiring parens.
+$([d| instance C (Maybe a) (Maybe b) c
+    |])
+
+-- ---------------------------------------------------------------------
+-- Patterns requiring parens according to hsPatNeedsParens
+
+-- SigPatIn. What about SigPatOut?
+$([d| g (a :: (Int -> Int) -> Int) = True |])
+
+-- ViewPat
+$([d| h (id -> x) = True |])
+
+-- PrefixCon with non-null args
+$([d| f (Just (Just False)) = True |])
+
+-- InfixCon for ConPatIn
+$([d| i (B (a `B` c) d) = True |])
+
+-- RecCon does not
+$([d| j B { aa = a} = True |])
+
+
+$([d| k = id @(Maybe Int) |])
+
+$([d| l = case Just 'a' of Just a -> Just ((\x -> x) a) |])
diff --git a/testsuite/tests/printer/T13199.stdout b/testsuite/tests/printer/T13199.stdout
new file mode 100644
index 0000000000..62e56590e0
--- /dev/null
+++ b/testsuite/tests/printer/T13199.stdout
@@ -0,0 +1,48 @@
+T13199.hs:(14,3)-(15,6): Splicing declarations
+    [d| instance C (Maybe a) (Maybe b) c |]
+  ======>
+    instance C (Maybe a) (Maybe b) c
+T13199.hs:21:3-44: Splicing declarations
+    [d| g (a :: (Int -> Int) -> Int) = True |]
+  ======>
+    g (a :: (Int -> Int) -> Int) = True
+T13199.hs:24:3-27: Splicing declarations
+    [d| h (id -> x) = True |] ======> h (id -> x) = True
+T13199.hs:27:3-37: Splicing declarations
+    [d| f (Just (Just False)) = True |]
+  ======>
+    f (Just (Just False)) = True
+T13199.hs:30:3-33: Splicing declarations
+    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
+T13199.hs:33:3-29: Splicing declarations
+    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
+T13199.hs:36:3-28: Splicing declarations
+    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
+T13199.hs:38:3-58: Splicing declarations
+    [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |]
+  ======>
+    l = case Just 'a' of { Just a -> Just ((\ x -> x) a) }
+T13199.ppr.hs:11:3-41: Splicing declarations
+    [d| instance C (Maybe a) (Maybe b) c |]
+  ======>
+    instance C (Maybe a) (Maybe b) c
+T13199.ppr.hs:12:3-44: Splicing declarations
+    [d| g (a :: (Int -> Int) -> Int) = True |]
+  ======>
+    g (a :: (Int -> Int) -> Int) = True
+T13199.ppr.hs:13:3-27: Splicing declarations
+    [d| h (id -> x) = True |] ======> h (id -> x) = True
+T13199.ppr.hs:14:3-37: Splicing declarations
+    [d| f (Just (Just False)) = True |]
+  ======>
+    f (Just (Just False)) = True
+T13199.ppr.hs:15:3-33: Splicing declarations
+    [d| i (B (a `B` c) d) = True |] ======> i (B (a `B` c) d) = True
+T13199.ppr.hs:16:3-28: Splicing declarations
+    [d| j B {aa = a} = True |] ======> j B {aa = a} = True
+T13199.ppr.hs:17:3-28: Splicing declarations
+    [d| k = id @(Maybe Int) |] ======> k = id @(Maybe Int)
+T13199.ppr.hs:18:3-63: Splicing declarations
+    [d| l = case Just 'a' of { Just a -> Just ((\ x -> x) a) } |]
+  ======>
+    l = case Just 'a' of { Just a -> Just ((\ x -> x) a) }
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index e0cfcc23a9..3106f936ba 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -46,3 +46,4 @@ test('Ppr045', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr04
 test('Ppr046', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr046'])
 test('Ppr047', expect_fail, run_command, ['$MAKE -s --no-print-directory ppr047'])
 test('Ppr048', ignore_stderr, run_command, ['$MAKE -s --no-print-directory ppr048'])
+test('T13199', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T13199'])
diff --git a/testsuite/tests/th/T12530.stderr b/testsuite/tests/th/T12530.stderr
index d2d1820742..0ba15360ac 100644
--- a/testsuite/tests/th/T12530.stderr
+++ b/testsuite/tests/th/T12530.stderr
@@ -5,6 +5,6 @@ T12530.hs:(8,3)-(15,6): Splicing declarations
         g = undefined @(_) @(a) |]
   ======>
     f :: Maybe Int -> Maybe Int
-    f = id @Maybe Int
+    f = id @(Maybe Int)
     g :: forall a. a
     g = undefined @_ @a