[Git][ghc/ghc][master] Fix #16666 by parenthesizing contexts in Convert

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
4a6c8436 by Ryan Scott at 2019-05-21T21:19:22Z
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 changed files:

- compiler/hsSyn/Convert.hs
- + testsuite/tests/th/T16666.hs
- + testsuite/tests/th/T16666.stderr
- testsuite/tests/th/all.T


Changes:

=====================================
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 }
 


=====================================
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
+    |])


=====================================
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


=====================================
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'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/4a6c8436f974cafc36a6e0462878614bdc0899c0

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/4a6c8436f974cafc36a6e0462878614bdc0899c0
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190521/784b5cf5/attachment-0001.html>