Commit 02b2116e authored by Ryan Scott's avatar Ryan Scott Committed by Ben Gamari

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
parent c5b477c2
......@@ -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 }
......
......@@ -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.
......@@ -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)
......
{-# 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)
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 = (==)
......@@ -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'])
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment