Fix #15738 by defining (and using) parenthesizeHsContext

With `QuantifiedConstraints`, `forall`s can appear in more
nested positions than they could before, but `Convert` and the TH
pretty-printer were failing to take this into account. On the
`Convert` side, this is fixed by using a `parenthesizeHsContext`
to parenthesize singleton quantified constraints that appear to the
left of a `=>`. (A similar fix is applied to the TH pretty-printer.)

Test Plan: make test TEST=T15738

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, carter

GHC Trac Issues: #15738

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

6 files changed, 41 insertions, 2 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index d094e17a14..af2c6034a9 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -1341,10 +1341,11 @@ cvtTypeKind ty_str ty
              | null tys'
              -> do { tvs' <- cvtTvs tvs
                    ; cxt' <- cvtContext cxt
+                   ; let pcxt = parenthesizeHsContext funPrec cxt'
                    ; ty'  <- cvtType ty
                    ; loc <- getL
                    ; let hs_ty  = mkHsForAllTy tvs loc tvs' rho_ty
-                         rho_ty = mkHsQualTy cxt loc cxt' ty'
+                         rho_ty = mkHsQualTy cxt loc pcxt ty'
 
                    ; return hs_ty }
 
diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs
index 3d853db32d..c36a54f66d 100644
--- a/compiler/hsSyn/HsTypes.hs
+++ b/compiler/hsSyn/HsTypes.hs
@@ -65,7 +65,7 @@ module HsTypes (
         -- Printing
         pprHsType, pprHsForAll, pprHsForAllTvs, pprHsForAllExtra,
         pprHsContext, pprHsContextNoArrow, pprHsContextMaybe,
-        hsTypeNeedsParens, parenthesizeHsType
+        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext
     ) where
 
 import GhcPrelude
@@ -1495,3 +1495,15 @@ parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)
 parenthesizeHsType p lty@(L loc ty)
   | hsTypeNeedsParens p ty = L loc (HsParTy NoExt lty)
   | otherwise              = lty
+
+-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint
+-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@
+-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply
+-- returns @ctxt@ unchanged.
+parenthesizeHsContext :: PprPrec
+                      -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)
+parenthesizeHsContext p lctxt@(L loc ctxt) =
+  case ctxt of
+    [c] -> L loc [parenthesizeHsType p c]
+    _   -> lctxt -- Other contexts are already "parenthesized" by virtue of
+                 -- being tuples.
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 8158af6ffd..7df8c98643 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -795,6 +795,7 @@ pprCxt ts = ppr_cxt_preds ts <+> text "=>"
 ppr_cxt_preds :: Cxt -> Doc
 ppr_cxt_preds [] = empty
 ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t)
+ppr_cxt_preds [t@ForallT{}] = parens (ppr t)
 ppr_cxt_preds [t] = ppr t
 ppr_cxt_preds ts = parens (commaSep ts)
 
diff --git a/testsuite/tests/th/T15738.hs b/testsuite/tests/th/T15738.hs
new file mode 100644
index 0000000000..4bc2d45686
--- /dev/null
+++ b/testsuite/tests/th/T15738.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T15738 where
+
+import Language.Haskell.TH
+import System.IO
+
+data Foo x = MkFoo x
+
+$(do d <- [d| f :: (forall a. Eq (Foo a)) => Foo x -> Foo x -> Bool
+              f = (==) |]
+     runIO $ hPutStrLn stderr $ pprint d
+     pure d)
diff --git a/testsuite/tests/th/T15738.stderr b/testsuite/tests/th/T15738.stderr
new file mode 100644
index 0000000000..57a2db5832
--- /dev/null
+++ b/testsuite/tests/th/T15738.stderr
@@ -0,0 +1,11 @@
+f_0 :: (forall a_1 . GHC.Classes.Eq (T15738.Foo a_1)) =>
+       T15738.Foo x_2 -> T15738.Foo x_2 -> GHC.Types.Bool
+f_0 = (GHC.Classes.==)
+T15738.hs:(10,3)-(13,11): Splicing declarations
+    do d <- [d| f :: (forall a. Eq (Foo a)) => Foo x -> Foo x -> Bool
+                f = (==) |]
+       runIO $ hPutStrLn stderr $ pprint d
+       pure d
+  ======>
+    f :: (forall a. Eq (Foo a)) => Foo x -> Foo x -> Bool
+    f = (==)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 249493e0ff..df114b57bf 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -438,3 +438,4 @@ test('TH_implicitParamsErr3', normal, compile_fail, ['-v0 -dsuppress-uniques'])
 test('TH_recursiveDo', normal, compile_and_run, ['-v0 -dsuppress-uniques'])
 test('T15481', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('TH_recover_warns', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T15738', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])