From 4a6c8436f974cafc36a6e0462878614bdc0899c0 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Thu, 16 May 2019 17:50:33 -0400
Subject: [PATCH] Fix #16666 by parenthesizing contexts in Convert
Most places where we convert contexts in `Convert` are actually in
positions that are to the left of some `=>`, such as in superclasses
and instance contexts. Accordingly, these contexts need to be
parenthesized at `funPrec`. To accomplish this, this patch changes
`cvtContext` to require a precedence argument for the purposes of
calling `parenthesizeHsContext` and adjusts all `cvtContext` call
sites accordingly.
---
compiler/hsSyn/Convert.hs | 22 +++++++++++-----------
testsuite/tests/th/T16666.hs | 11 +++++++++++
testsuite/tests/th/T16666.stderr | 7 +++++++
testsuite/tests/th/all.T | 1 +
4 files changed, 30 insertions(+), 11 deletions(-)
create mode 100644 testsuite/tests/th/T16666.hs
create mode 100644 testsuite/tests/th/T16666.stderr
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 77ffebe02123..22e1a5a2ae4e 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -269,7 +269,7 @@ cvtDec (InstanceD o ctxt ty decs)
= do { let doc = text "an instance declaration"
; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
- ; ctxt' <- cvtContext ctxt
+ ; ctxt' <- cvtContext funPrec ctxt
; (dL->L loc ty') <- cvtType ty
; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'
; returnJustL $ InstD noExt $ ClsInstD noExt $
@@ -365,7 +365,7 @@ cvtDec (TH.RoleAnnotD tc roles)
; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }
cvtDec (TH.StandaloneDerivD ds cxt ty)
- = do { cxt' <- cvtContext cxt
+ = do { cxt' <- cvtContext funPrec cxt
; ds' <- traverse cvtDerivStrategy ds
; (dL->L loc ty') <- cvtType ty
; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'
@@ -471,7 +471,7 @@ cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]
, Located RdrName
, LHsQTyVars GhcPs)
cvt_tycl_hdr cxt tc tvs
- = do { cxt' <- cvtContext cxt
+ = do { cxt' <- cvtContext funPrec cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
; return (cxt', tc', tvs')
@@ -483,7 +483,7 @@ cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type
, Maybe [LHsTyVarBndr GhcPs]
, HsTyPats GhcPs)
cvt_datainst_hdr cxt bndrs tys
- = do { cxt' <- cvtContext cxt
+ = do { cxt' <- cvtContext funPrec cxt
; bndrs' <- traverse (mapM cvt_tv) bndrs
; (head_ty, args) <- split_ty_app tys
; case head_ty of
@@ -573,7 +573,7 @@ cvtConstr (InfixC st1 c st2)
cvtConstr (ForallC tvs ctxt con)
= do { tvs' <- cvtTvs tvs
- ; ctxt' <- cvtContext ctxt
+ ; ctxt' <- cvtContext funPrec ctxt
; (dL->L _ con') <- cvtConstr con
; returnL $ add_forall tvs' ctxt' con' }
where
@@ -1304,8 +1304,9 @@ cvtRole TH.RepresentationalR = Just Coercion.Representational
cvtRole TH.PhantomR = Just Coercion.Phantom
cvtRole TH.InferR = Nothing
-cvtContext :: TH.Cxt -> CvtM (LHsContext GhcPs)
-cvtContext tys = do { preds' <- mapM cvtPred tys; returnL preds' }
+cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)
+cvtContext p tys = do { preds' <- mapM cvtPred tys
+ ; parenthesizeHsContext p <$> returnL preds' }
cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)
cvtPred = cvtType
@@ -1313,7 +1314,7 @@ cvtPred = cvtType
cvtDerivClause :: TH.DerivClause
-> CvtM (LHsDerivingClause GhcPs)
cvtDerivClause (TH.DerivClause ds ctxt)
- = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext ctxt
+ = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt
; ds' <- traverse cvtDerivStrategy ds
; returnL $ HsDerivingClause noExt ds' ctxt' }
@@ -1409,12 +1410,11 @@ cvtTypeKind ty_str ty
ForallT tvs cxt ty
| null tys'
-> do { tvs' <- cvtTvs tvs
- ; cxt' <- cvtContext cxt
- ; let pcxt = parenthesizeHsContext funPrec cxt'
+ ; cxt' <- cvtContext funPrec cxt
; ty' <- cvtType ty
; loc <- getL
; let hs_ty = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty
- rho_ty = mkHsQualTy cxt loc pcxt ty'
+ rho_ty = mkHsQualTy cxt loc cxt' ty'
; return hs_ty }
diff --git a/testsuite/tests/th/T16666.hs b/testsuite/tests/th/T16666.hs
new file mode 100644
index 000000000000..88351fd5a722
--- /dev/null
+++ b/testsuite/tests/th/T16666.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuantifiedConstraints #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE UndecidableInstances #-}
+module T16666 where
+
+$([d| class (c => d) => Implies c d
+ instance (c => d) => Implies c d
+ |])
diff --git a/testsuite/tests/th/T16666.stderr b/testsuite/tests/th/T16666.stderr
new file mode 100644
index 000000000000..82649673969d
--- /dev/null
+++ b/testsuite/tests/th/T16666.stderr
@@ -0,0 +1,7 @@
+T16666.hs:(9,3)-(11,6): Splicing declarations
+ [d| class (c => d) => Implies c d
+
+ instance (c => d) => Implies c d |]
+ ======>
+ class (c => d) => Implies c d
+ instance (c => d) => Implies c d
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index f9738615c79c..37d21c370793 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -473,3 +473,4 @@ test('T16195', normal, multimod_compile, ['T16195.hs', '-v0'])
test('T16293b', normal, compile, [''])
test('T16326_TH', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T14741', normal, compile_and_run, [''])
+test('T16666', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
--
GitLab