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.

4 files changed, 30 insertions, 11 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 77ffebe021..22e1a5a2ae 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 0000000000..88351fd5a7
--- /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 0000000000..8264967396
--- /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 f9738615c7..37d21c3707 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'])