Fix unparseable pretty-printing of promoted data cons

Previously we would print code which would not round-trip:
```
> :set -XDataKinds
> :set -XPolyKinds
> data Proxy k = Proxy
> _ :: Proxy '[ 'True ]
error:
  Found hole: _ :: Proxy '['True]
> _ :: Proxy '['True]
error:
    Invalid type signature: _ :: ...
    Should be of form <variable> :: <type>
```

Test Plan: Validate with T14343

Reviewers: RyanGlScott, goldfire, bgamari, tdammers

Reviewed By: RyanGlScott, bgamari

Subscribers: tdammers, rwbarton, thomie, carter

GHC Trac Issues: #14343

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

11 files changed, 147 insertions, 26 deletions

diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs
index 2524593663..e2e51d8c58 100644
--- a/compiler/iface/IfaceType.hs
+++ b/compiler/iface/IfaceType.hs
@@ -933,6 +933,15 @@ criteria are met:
 
 -------------------
 
+-- | Prefix a space if the given 'IfaceType' is a promoted 'TyCon'.
+pprSpaceIfPromotedTyCon :: IfaceType -> SDoc -> SDoc
+pprSpaceIfPromotedTyCon (IfaceTyConApp tyCon _)
+  = case ifaceTyConIsPromoted (ifaceTyConInfo tyCon) of
+      IsPromoted -> (space <>)
+      _ -> id
+pprSpaceIfPromotedTyCon _
+  = id
+
 -- See equivalent function in TyCoRep.hs
 pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
 -- Given a type-level list (t1 ': t2), see if we can print
@@ -941,8 +950,8 @@ pprIfaceTyList :: PprPrec -> IfaceType -> IfaceType -> SDoc
 pprIfaceTyList ctxt_prec ty1 ty2
   = case gather ty2 of
       (arg_tys, Nothing)
-        -> char '\'' <> brackets (fsep (punctuate comma
-                        (map (ppr_ty topPrec) (ty1:arg_tys))))
+        -> char '\'' <> brackets (pprSpaceIfPromotedTyCon ty1 (fsep
+                        (punctuate comma (map (ppr_ty topPrec) (ty1:arg_tys)))))
       (arg_tys, Just tl)
         -> maybeParen ctxt_prec funPrec $ hang (ppr_ty funPrec ty1)
            2 (fsep [ colon <+> ppr_ty funPrec ty | ty <- arg_tys ++ [tl]])
@@ -1136,8 +1145,11 @@ pprTuple ctxt_prec ConstraintTuple IsNotPromoted ITC_Nil
 pprTuple _ sort IsPromoted args
   = let tys = tcArgsIfaceTypes args
         args' = drop (length tys `div` 2) tys
+        spaceIfPromoted = case args' of
+          arg0:_ -> pprSpaceIfPromotedTyCon arg0
+          _ -> id
     in pprPromotionQuoteI IsPromoted <>
-       tupleParens sort (pprWithCommas pprIfaceType args')
+       tupleParens sort (spaceIfPromoted (pprWithCommas pprIfaceType args'))
 
 pprTuple _ sort promoted args
   =   -- drop the RuntimeRep vars.
diff --git a/testsuite/tests/perf/compiler/T13035.stderr b/testsuite/tests/perf/compiler/T13035.stderr
index fe1f0b2564..4fbc7c7e37 100644
--- a/testsuite/tests/perf/compiler/T13035.stderr
+++ b/testsuite/tests/perf/compiler/T13035.stderr
@@ -1,4 +1,4 @@
 
 T13035.hs:141:28: warning: [-Wpartial-type-signatures (in -Wdefault)]
-    • Found type wildcard ‘_’ standing for ‘'['Author] :: [Fields]’
+    • Found type wildcard ‘_’ standing for ‘'[ 'Author] :: [Fields]’
     • In the type signature: g :: MyRec RecipeFormatter _
diff --git a/testsuite/tests/perf/compiler/T9872b.stderr b/testsuite/tests/perf/compiler/T9872b.stderr
index d2d8ad8441..6224056185 100644
--- a/testsuite/tests/perf/compiler/T9872b.stderr
+++ b/testsuite/tests/perf/compiler/T9872b.stderr
@@ -2,22 +2,22 @@
 T9872b.hs:19:8:
     No instance for (Show
                        (Proxy
-                          '['['Cube 'G 'B 'W 'R 'B 'G, 'Cube 'W 'G 'B 'W 'R 'R,
-                              'Cube 'R 'W 'R 'B 'G 'R, 'Cube 'B 'R 'G 'G 'W 'W],
-                            '['Cube 'G 'B 'R 'W 'B 'G, 'Cube 'R 'R 'W 'B 'G 'W,
-                              'Cube 'R 'G 'B 'R 'W 'R, 'Cube 'W 'W 'G 'G 'R 'B],
-                            '['Cube 'G 'W 'R 'B 'B 'G, 'Cube 'W 'B 'W 'R 'G 'R,
-                              'Cube 'R 'R 'B 'G 'W 'R, 'Cube 'B 'G 'G 'W 'R 'W],
-                            '['Cube 'G 'R 'W 'B 'B 'G, 'Cube 'R 'W 'B 'G 'R 'W,
-                              'Cube 'R 'B 'R 'W 'G 'R, 'Cube 'W 'G 'G 'R 'W 'B],
-                            '['Cube 'G 'R 'B 'B 'W 'G, 'Cube 'W 'W 'R 'G 'B 'R,
-                              'Cube 'R 'B 'G 'W 'R 'R, 'Cube 'B 'G 'W 'R 'G 'W],
-                            '['Cube 'G 'W 'B 'B 'R 'G, 'Cube 'R 'B 'G 'R 'W 'W,
-                              'Cube 'R 'R 'W 'G 'B 'R, 'Cube 'W 'G 'R 'W 'G 'B],
-                            '['Cube 'G 'B 'B 'W 'R 'G, 'Cube 'W 'R 'G 'B 'W 'R,
-                              'Cube 'R 'G 'W 'R 'B 'R, 'Cube 'B 'W 'R 'G 'G 'W],
-                            '['Cube 'G 'B 'B 'R 'W 'G, 'Cube 'R 'G 'R 'W 'B 'W,
-                              'Cube 'R 'W 'G 'B 'R 'R, 'Cube 'W 'R 'W 'G 'G 'B]]))
+                          '[ '[ 'Cube 'G 'B 'W 'R 'B 'G, 'Cube 'W 'G 'B 'W 'R 'R,
+                                'Cube 'R 'W 'R 'B 'G 'R, 'Cube 'B 'R 'G 'G 'W 'W],
+                             '[ 'Cube 'G 'B 'R 'W 'B 'G, 'Cube 'R 'R 'W 'B 'G 'W,
+                                'Cube 'R 'G 'B 'R 'W 'R, 'Cube 'W 'W 'G 'G 'R 'B],
+                             '[ 'Cube 'G 'W 'R 'B 'B 'G, 'Cube 'W 'B 'W 'R 'G 'R,
+                                'Cube 'R 'R 'B 'G 'W 'R, 'Cube 'B 'G 'G 'W 'R 'W],
+                             '[ 'Cube 'G 'R 'W 'B 'B 'G, 'Cube 'R 'W 'B 'G 'R 'W,
+                                'Cube 'R 'B 'R 'W 'G 'R, 'Cube 'W 'G 'G 'R 'W 'B],
+                             '[ 'Cube 'G 'R 'B 'B 'W 'G, 'Cube 'W 'W 'R 'G 'B 'R,
+                                'Cube 'R 'B 'G 'W 'R 'R, 'Cube 'B 'G 'W 'R 'G 'W],
+                             '[ 'Cube 'G 'W 'B 'B 'R 'G, 'Cube 'R 'B 'G 'R 'W 'W,
+                                'Cube 'R 'R 'W 'G 'B 'R, 'Cube 'W 'G 'R 'W 'G 'B],
+                             '[ 'Cube 'G 'B 'B 'W 'R 'G, 'Cube 'W 'R 'G 'B 'W 'R,
+                                'Cube 'R 'G 'W 'R 'B 'R, 'Cube 'B 'W 'R 'G 'G 'W],
+                             '[ 'Cube 'G 'B 'B 'R 'W 'G, 'Cube 'R 'G 'R 'W 'B 'W,
+                                'Cube 'R 'W 'G 'B 'R 'R, 'Cube 'W 'R 'W 'G 'G 'B]]))
       arising from a use of ‘print’
     In the expression: print (Proxy :: Proxy (Solutions Cubes))
     In an equation for ‘main’:
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index 17fc65215f..044e44332e 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -229,3 +229,11 @@ T14289c:
 .PHONY: T14306
 T14306:
 	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14306.hs
+
+.PHONY: T14343
+T14343:
+	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343.hs
+
+.PHONY: T14343b
+T14343b:
+	$(CHECK_PPR) "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`" T14343b.hs
diff --git a/testsuite/tests/printer/T14343.hs b/testsuite/tests/printer/T14343.hs
new file mode 100644
index 0000000000..1fe6a9660b
--- /dev/null
+++ b/testsuite/tests/printer/T14343.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# OPTIONS_GHC -Werror=typed-holes #-}
+
+main :: IO ()
+main = undefined
+
+data Proxy k = Proxy
+
+test1 = _ :: Proxy '[ 'True ]
+test2 = _ :: Proxy '[ '[ 1 ] ]
+test3 = _ :: Proxy '[ '( "Symbol", 1 ) ]
diff --git a/testsuite/tests/printer/T14343.stderr b/testsuite/tests/printer/T14343.stderr
new file mode 100644
index 0000000000..1bceb67403
--- /dev/null
+++ b/testsuite/tests/printer/T14343.stderr
@@ -0,0 +1,36 @@
+
+T14343.hs:10:9: error:
+    • Found hole: _ :: Proxy '[ 'True]
+    • In the expression: _ :: Proxy '[ 'True]
+      In an equation for ‘test1’: test1 = _ :: Proxy '[ 'True]
+    • Relevant bindings include
+        test1 :: Proxy '[ 'True] (bound at T14343.hs:10:1)
+      Valid hole fits include
+        test1 :: Proxy '[ 'True] (defined at T14343.hs:10:1)
+        Proxy :: forall k1 (k2 :: k1). Proxy k2
+          with Proxy @[Bool] @'[ 'True]
+          (defined at T14343.hs:8:16)
+
+T14343.hs:11:9: error:
+    • Found hole: _ :: Proxy '[ '[1]]
+    • In the expression: _ :: Proxy '['[1]]
+      In an equation for ‘test2’: test2 = _ :: Proxy '['[1]]
+    • Relevant bindings include
+        test2 :: Proxy '[ '[1]] (bound at T14343.hs:11:1)
+      Valid hole fits include
+        test2 :: Proxy '[ '[1]] (defined at T14343.hs:11:1)
+        Proxy :: forall k1 (k2 :: k1). Proxy k2
+          with Proxy @[[GHC.Types.Nat]] @'[ '[1]]
+          (defined at T14343.hs:8:16)
+
+T14343.hs:12:9: error:
+    • Found hole: _ :: Proxy '[ '("Symbol", 1)]
+    • In the expression: _ :: Proxy '['("Symbol", 1)]
+      In an equation for ‘test3’: test3 = _ :: Proxy '['("Symbol", 1)]
+    • Relevant bindings include
+        test3 :: Proxy '[ '("Symbol", 1)] (bound at T14343.hs:12:1)
+      Valid hole fits include
+        test3 :: Proxy '[ '("Symbol", 1)] (defined at T14343.hs:12:1)
+        Proxy :: forall k1 (k2 :: k1). Proxy k2
+          with Proxy @[(GHC.Types.Symbol, GHC.Types.Nat)] @'[ '("Symbol", 1)]
+          (defined at T14343.hs:8:16)
diff --git a/testsuite/tests/printer/T14343b.hs b/testsuite/tests/printer/T14343b.hs
new file mode 100644
index 0000000000..6596a7a486
--- /dev/null
+++ b/testsuite/tests/printer/T14343b.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# OPTIONS_GHC -Werror=typed-holes #-}
+
+main :: IO ()
+main = undefined
+
+data Proxy k = Proxy
+
+test1 = _ :: Proxy '( 'True, 'False )
+test2 = _ :: Proxy '( '( 'True, 'False ), 'False )
+test3 = _ :: Proxy '( '[ 1 ], 'False )
diff --git a/testsuite/tests/printer/T14343b.stderr b/testsuite/tests/printer/T14343b.stderr
new file mode 100644
index 0000000000..1954f9465a
--- /dev/null
+++ b/testsuite/tests/printer/T14343b.stderr
@@ -0,0 +1,39 @@
+
+T14343b.hs:10:9: error:
+    • Found hole: _ :: Proxy '( 'True, 'False)
+    • In the expression: _ :: Proxy '( 'True,  'False)
+      In an equation for ‘test1’: test1 = _ :: Proxy '( 'True,  'False)
+    • Relevant bindings include
+        test1 :: Proxy '( 'True, 'False) (bound at T14343b.hs:10:1)
+      Valid hole fits include
+        test1 :: Proxy '( 'True, 'False) (defined at T14343b.hs:10:1)
+        Proxy :: forall k1 (k2 :: k1). Proxy k2
+          with Proxy @(Bool, Bool) @'( 'True, 'False)
+          (defined at T14343b.hs:8:16)
+
+T14343b.hs:11:9: error:
+    • Found hole: _ :: Proxy '( '( 'True, 'False), 'False)
+    • In the expression: _ :: Proxy '('( 'True,  'False),  'False)
+      In an equation for ‘test2’:
+          test2 = _ :: Proxy '('( 'True,  'False),  'False)
+    • Relevant bindings include
+        test2 :: Proxy '( '( 'True, 'False), 'False)
+          (bound at T14343b.hs:11:1)
+      Valid hole fits include
+        test2 :: Proxy '( '( 'True, 'False), 'False)
+          (defined at T14343b.hs:11:1)
+        Proxy :: forall k1 (k2 :: k1). Proxy k2
+          with Proxy @((Bool, Bool), Bool) @'( '( 'True, 'False), 'False)
+          (defined at T14343b.hs:8:16)
+
+T14343b.hs:12:9: error:
+    • Found hole: _ :: Proxy '( '[1], 'False)
+    • In the expression: _ :: Proxy '('[1],  'False)
+      In an equation for ‘test3’: test3 = _ :: Proxy '('[1],  'False)
+    • Relevant bindings include
+        test3 :: Proxy '( '[1], 'False) (bound at T14343b.hs:12:1)
+      Valid hole fits include
+        test3 :: Proxy '( '[1], 'False) (defined at T14343b.hs:12:1)
+        Proxy :: forall k1 (k2 :: k1). Proxy k2
+          with Proxy @([GHC.Types.Nat], Bool) @'( '[1], 'False)
+          (defined at T14343b.hs:8:16)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 7dda6b36fa..203efa4be4 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -54,3 +54,5 @@ test('T14289', ignore_stderr, run_command, ['$MAKE -s --no-print-directory T1428
 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'])
+test('T14343', normal, compile_fail, [''])
+test('T14343b', normal, compile_fail, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T15067.stderr b/testsuite/tests/typecheck/should_fail/T15067.stderr
index 73056113ad..4ed3d3bc0a 100644
--- a/testsuite/tests/typecheck/should_fail/T15067.stderr
+++ b/testsuite/tests/typecheck/should_fail/T15067.stderr
@@ -1,13 +1,13 @@
 
-T15067.hs:9:14:
-     No instance for (Typeable (# 'GHC.Types.LiftedRep #))
+T15067.hs:9:14: error:
+    • No instance for (Typeable (# 'GHC.Types.LiftedRep #))
         arising from a use of ‘typeRep’
         GHC can't yet do polykinded
           Typeable ((# 'GHC.Types.LiftedRep #) :: *
                                                   -> *
                                                   -> TYPE
                                                        ('GHC.Types.SumRep
-                                                          '['GHC.Types.LiftedRep,
-                                                            'GHC.Types.LiftedRep]))
-     In the expression: typeRep
+                                                          '[ 'GHC.Types.LiftedRep,
+                                                             'GHC.Types.LiftedRep]))
+    • In the expression: typeRep
       In an equation for ‘floopadoop’: floopadoop = typeRep
diff --git a/testsuite/tests/unboxedsums/T12711.stdout b/testsuite/tests/unboxedsums/T12711.stdout
index 7a623a3bd6..54af3fdfa6 100644
--- a/testsuite/tests/unboxedsums/T12711.stdout
+++ b/testsuite/tests/unboxedsums/T12711.stdout
@@ -1,2 +1,2 @@
 (# _ | _ #) :: TYPE
-                 ('GHC.Types.SumRep '['GHC.Types.LiftedRep, 'GHC.Types.LiftedRep])
+                 ('GHC.Types.SumRep '[ 'GHC.Types.LiftedRep, 'GHC.Types.LiftedRep])