[commit: ghc] master: Fix #15738 by defining (and using) parenthesizeHsContext (02b2116)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/02b2116e458357e87718e7378a80579a7021e2a7/ghc

>---------------------------------------------------------------

commit 02b2116e458357e87718e7378a80579a7021e2a7
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date:   Mon Oct 15 13:49:11 2018 -0400

    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


>---------------------------------------------------------------

02b2116e458357e87718e7378a80579a7021e2a7
 compiler/hsSyn/Convert.hs                             |  3 ++-
 compiler/hsSyn/HsTypes.hs                             | 14 +++++++++++++-
 libraries/template-haskell/Language/Haskell/TH/Ppr.hs |  1 +
 testsuite/tests/th/T15738.hs                          | 13 +++++++++++++
 testsuite/tests/th/T15738.stderr                      | 11 +++++++++++
 testsuite/tests/th/all.T                              |  1 +
 6 files changed, 41 insertions(+), 2 deletions(-)

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index d094e17..af2c603 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 3d853db..c36a54f 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 at . 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 8158af6..7df8c98 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 at ImplicitParamT{}] = parens (ppr t)
+ppr_cxt_preds [t at 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 0000000..4bc2d45
--- /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 0000000..57a2db5
--- /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 249493e..df114b5 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'])