Commit ad3d2dfa authored by Ryan Scott's avatar Ryan Scott

Don't unnecessarily qualify TH-converted instances with empty contexts

Summary:
The addition of rigorous pretty-printer tests
(499e4382) had the unfortunate
side-effect of revealing a bug in `hsSyn/Convert.hs` wherein instances are
_always_ qualified with an instance context, even if the context is empty. This
led to instances like this:

```
instance Foo Int
```

being pretty-printed like this!

```
instance () => Foo Int
```

We can prevent this by checking if the context is empty before adding an
HsQualTy to the type.

Also does some refactoring around HsForAllTys in `Convert` while I was in town.

Fixes #13183.

Test Plan: ./validate

Reviewers: goldfire, bgamari, austin, alanz

Reviewed By: alanz

Subscribers: mpickering, thomie

Differential Revision: https://phabricator.haskell.org/D3018

GHC Trac Issues: #13183
parent 50544eea
......@@ -260,7 +260,7 @@ cvtDec (InstanceD o ctxt ty decs)
; unless (null fams') (failWith (mkBadDecMsg doc fams'))
; ctxt' <- cvtContext ctxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = L loc ty' }
; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ L loc ty'
; returnJustL $ InstD $ ClsInstD $
ClsInstDecl { cid_poly_ty = mkLHsSigType inst_ty'
, cid_binds = binds'
......@@ -346,7 +346,7 @@ cvtDec (TH.RoleAnnotD tc roles)
cvtDec (TH.StandaloneDerivD ds cxt ty)
= do { cxt' <- cvtContext cxt
; L loc ty' <- cvtType ty
; let inst_ty' = L loc $ HsQualTy { hst_ctxt = cxt', hst_body = L loc ty' }
; let inst_ty' = mkHsQualTy cxt loc cxt' $ L loc ty'
; returnJustL $ DerivD $
DerivDecl { deriv_strategy = fmap (L loc . cvtDerivStrategy) ds
, deriv_type = mkLHsSigType inst_ty'
......@@ -510,16 +510,9 @@ cvtConstr (ForallC tvs ctxt con)
; L _ con' <- cvtConstr con
; returnL $ case con' of
ConDeclGADT { con_type = conT } ->
let hs_ty
| null tvs = rho_ty
| otherwise = noLoc $ HsForAllTy
{ hst_bndrs = hsq_explicit tvs'
, hst_body = rho_ty }
rho_ty
| null ctxt = hsib_body conT
| otherwise = noLoc $ HsQualTy
{ hst_ctxt = L loc ctxt'
, hst_body = hsib_body conT }
let hs_ty = mkHsForAllTy tvs noSrcSpan tvs' rho_ty
rho_ty = mkHsQualTy ctxt noSrcSpan (L loc ctxt')
(hsib_body conT)
in con' { con_type = HsIB PlaceHolder hs_ty }
ConDeclH98 {} ->
let qvars = case (tvs, con_qvars con') of
......@@ -1221,12 +1214,8 @@ cvtTypeKind ty_str ty
; cxt' <- cvtContext cxt
; ty' <- cvtType ty
; loc <- getL
; let hs_ty | null tvs = rho_ty
| otherwise = L loc (HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
, hst_body = rho_ty })
rho_ty | null cxt = ty'
| otherwise = L loc (HsQualTy { hst_ctxt = cxt'
, hst_body = ty' })
; let hs_ty = mkHsForAllTy tvs loc tvs' rho_ty
rho_ty = mkHsQualTy cxt loc cxt' ty'
; return hs_ty }
......@@ -1433,6 +1422,47 @@ unboxedSumChecks alt arity
| otherwise
= return ()
-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the
-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'
-- using the provided 'LHsQTyVars' and 'LHsType'.
mkHsForAllTy :: [TH.TyVarBndr]
-- ^ The original Template Haskell type variable binders
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit forall
-> LHsQTyVars name
-- ^ The converted type variable binders
-> LHsType name
-- ^ The converted rho type
-> LHsType name
-- ^ The complete type, quantified with a forall if necessary
mkHsForAllTy tvs loc tvs' rho_ty
| null tvs = rho_ty
| otherwise = L loc $ HsForAllTy { hst_bndrs = hsQTvExplicit tvs'
, hst_body = rho_ty }
-- | If passed an empty 'TH.Cxt', this simply returns the third argument
-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided
-- 'LHsContext' and 'LHsType'.
-- It's important that we don't build an HsQualTy if the context is empty,
-- as the pretty-printer for HsType _always_ prints contexts, even if
-- they're empty. See Trac #13183.
mkHsQualTy :: TH.Cxt
-- ^ The original Template Haskell context
-> SrcSpan
-- ^ The location of the returned 'LHsType' if it needs an
-- explicit context
-> LHsContext name
-- ^ The converted context
-> LHsType name
-- ^ The converted tau type
-> LHsType name
-- ^ The complete type, qualified with a context if necessary
mkHsQualTy ctxt loc ctxt' ty
| null ctxt = ty
| otherwise = L loc $ HsQualTy { hst_ctxt = ctxt', hst_body = ty }
--------------------------------------------------------------------
-- Turning Name back into RdrName
--------------------------------------------------------------------
......
......@@ -36,6 +36,6 @@ T10598_TH.hs:(27,3)-(42,50): Splicing declarations
deriving stock Eq
deriving anyclass C
deriving newtype Read
deriving stock instance () => Ord Foo
deriving anyclass instance () => D Foo
deriving newtype instance () => Show Foo
deriving stock instance Ord Foo
deriving anyclass instance D Foo
deriving newtype instance Show Foo
T5700.hs:8:3-9: Splicing declarations
mkC ''D
======>
instance () => C D where
instance C D where
{-# INLINE inlinable #-}
inlinable _ = GHC.Tuple.()
......@@ -6,6 +6,6 @@ T5883.hs:(7,4)-(12,4): Splicing declarations
{-# INLINE show #-} |]
======>
data Unit = Unit
instance () => Show Unit where
instance Show Unit where
{-# INLINE show #-}
show _ = ""
......@@ -6,10 +6,10 @@ instance C Bool where
T7532.hs:11:3-7: Splicing declarations
bang'
======>
instance () => C Int where
instance C Int where
data D Int = T
==================== Renamer ====================
instance () => C Int where
instance C Int where
data D Int = T7532.T
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