[commit: ghc] master: Don't unnecessarily qualify TH-converted instances with empty contexts (ad3d2df)
git at git.haskell.org
git at git.haskell.org
Thu Jan 26 17:48:48 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/ad3d2dfa19a1ed788c682e8b0c7c6e66e63d3f79/ghc
>---------------------------------------------------------------
commit ad3d2dfa19a1ed788c682e8b0c7c6e66e63d3f79
Author: Ryan Scott <ryan.gl.scott at gmail.com>
Date: Thu Jan 26 12:31:59 2017 -0500
Don't unnecessarily qualify TH-converted instances with empty contexts
Summary:
The addition of rigorous pretty-printer tests
(499e43824bda967546ebf95ee33ec1f84a114a7c) 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
>---------------------------------------------------------------
ad3d2dfa19a1ed788c682e8b0c7c6e66e63d3f79
compiler/hsSyn/Convert.hs | 66 +++++++++++++++++++++++++++----------
testsuite/tests/th/T10598_TH.stderr | 6 ++--
testsuite/tests/th/T5700.stderr | 2 +-
testsuite/tests/th/T5883.stderr | 2 +-
testsuite/tests/th/T7532.stderr | 4 +--
5 files changed, 55 insertions(+), 25 deletions(-)
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index a1ea110..ad4abf8 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -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
--------------------------------------------------------------------
diff --git a/testsuite/tests/th/T10598_TH.stderr b/testsuite/tests/th/T10598_TH.stderr
index e149418..6471421 100644
--- a/testsuite/tests/th/T10598_TH.stderr
+++ b/testsuite/tests/th/T10598_TH.stderr
@@ -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
diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr
index f2f4288..729a366 100644
--- a/testsuite/tests/th/T5700.stderr
+++ b/testsuite/tests/th/T5700.stderr
@@ -1,6 +1,6 @@
T5700.hs:8:3-9: Splicing declarations
mkC ''D
======>
- instance () => C D where
+ instance C D where
{-# INLINE inlinable #-}
inlinable _ = GHC.Tuple.()
diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr
index b63ea2f..aa87a41 100644
--- a/testsuite/tests/th/T5883.stderr
+++ b/testsuite/tests/th/T5883.stderr
@@ -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 _ = ""
diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr
index 21b753b..baaf04f 100644
--- a/testsuite/tests/th/T7532.stderr
+++ b/testsuite/tests/th/T7532.stderr
@@ -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
More information about the ghc-commits
mailing list