[commit: ghc] wip/T13324: Use LHsSigWcType in DerivDecl (7d491ae)
git at git.haskell.org
git at git.haskell.org
Mon Mar 5 14:51:56 UTC 2018
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/T13324
Link : http://ghc.haskell.org/trac/ghc/changeset/7d491ae76b32a78c1ea09a324f67937adceecfc2/ghc
>---------------------------------------------------------------
commit 7d491ae76b32a78c1ea09a324f67937adceecfc2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Mon Mar 5 14:50:00 2018 +0000
Use LHsSigWcType in DerivDecl
This prepares the way for the fix for Trac #13324, by
using LHsSigWcType for the instance type in DerivDecl,
but nowhere else.
See comments on Phab:D4383
>---------------------------------------------------------------
7d491ae76b32a78c1ea09a324f67937adceecfc2
compiler/deSugar/DsMeta.hs | 2 +-
compiler/hsSyn/Convert.hs | 2 +-
compiler/hsSyn/HsDecls.hs | 2 +-
compiler/parser/Parser.y | 7 ++++---
compiler/rename/RnSource.hs | 9 ++++++---
compiler/rename/RnTypes.hs | 7 -------
compiler/typecheck/TcDeriv.hs | 7 +++++--
7 files changed, 18 insertions(+), 18 deletions(-)
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index 5029f9d..e1eaae1 100644
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -488,7 +488,7 @@ repStandaloneDerivD (L loc (DerivDecl { deriv_strategy = strat
; repDeriv strat' cxt' inst_ty' }
; return (loc, dec) }
where
- (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty
+ (tvs, cxt, inst_ty) = splitLHsInstDeclTy (hswc_body ty)
repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)
repTyFamInstD decl@(TyFamInstDecl { tfid_eqn = eqn })
diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index 531f146..6c2e58c 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -351,7 +351,7 @@ cvtDec (TH.StandaloneDerivD ds cxt 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'
+ , deriv_type = mkLHsSigWcType inst_ty'
, deriv_overlap_mode = Nothing } }
cvtDec (TH.DefaultSigD nm typ)
diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs
index 475e31e..660fc2a 100644
--- a/compiler/hsSyn/HsDecls.hs
+++ b/compiler/hsSyn/HsDecls.hs
@@ -1659,7 +1659,7 @@ type LDerivDecl pass = Located (DerivDecl pass)
-- | Deriving Declaration
data DerivDecl pass = DerivDecl
- { deriv_type :: LHsSigType pass
+ { deriv_type :: LHsSigWcType pass
, deriv_strategy :: Maybe (Located DerivStrategy)
, deriv_overlap_mode :: Maybe (Located OverlapMode)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDeriving',
diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y
index 898ed3c..bdb5e6b 100644
--- a/compiler/parser/Parser.y
+++ b/compiler/parser/Parser.y
@@ -1373,10 +1373,11 @@ capi_ctype : '{-# CTYPE' STRING STRING '#-}'
-- Glasgow extension: stand-alone deriving declarations
stand_alone_deriving :: { LDerivDecl GhcPs }
- : 'deriving' deriv_strategy 'instance' overlap_pragma inst_type
+ : 'deriving' deriv_strategy 'instance' overlap_pragma sigtype
{% do { let { err = text "in the stand-alone deriving instance"
- <> colon <+> quotes (ppr $5) }
- ; ams (sLL $1 (hsSigType $>) (DerivDecl $5 $2 $4))
+ <> colon <+> quotes (ppr $5)
+ ; inst_ty = mkLHsSigWcType $5 }
+ ; ams (sLL $1 $> (DerivDecl inst_ty $2 $4))
[mj AnnDeriving $1, mj AnnInstance $3] } }
-----------------------------------------------------------------------------
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 447871a..53feacb 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -634,7 +634,8 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
, cid_sigs = uprags, cid_tyfam_insts = ats
, cid_overlap_mode = oflag
, cid_datafam_insts = adts })
- = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
+ = do { let ctxt = GenericCtx (text "an instance declaration")
+ ; (inst_ty', inst_fvs) <- rnHsSigType ctxt inst_ty
; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
; let cls = case hsTyGetAppHead_maybe head_ty' of
Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
@@ -945,7 +946,8 @@ rnSrcDerivDecl (DerivDecl ty deriv_strat overlap)
; unless standalone_deriv_ok (addErr standaloneDerivErr)
; failIfTc (isJust deriv_strat && not deriv_strats_ok) $
illegalDerivStrategyErr $ fmap unLoc deriv_strat
- ; (ty', fvs) <- rnLHsInstType (text "a deriving declaration") ty
+ ; let ctxt = GenericCtx (text "a deriving declaration")
+ ; (ty', fvs) <- rnHsSigWcType ctxt ty
; return (DerivDecl ty' deriv_strat overlap, fvs) }
standaloneDerivErr :: SDoc
@@ -1124,7 +1126,8 @@ rnHsVectDecl (HsVectClassIn s cls)
rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn instTy)
- = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
+ = do { let ctxt = GenericCtx (text "a VECTORISE pragma")
+ ; (instTy', fvs) <- rnHsSigType ctxt instTy
; return (HsVectInstIn instTy', fvs)
}
rnHsVectDecl (HsVectInstOut _)
diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs
index b2dafb2..791881b 100644
--- a/compiler/rename/RnTypes.hs
+++ b/compiler/rename/RnTypes.hs
@@ -13,7 +13,6 @@ module RnTypes (
rnHsKind, rnLHsKind,
rnHsSigType, rnHsWcType,
rnHsSigWcType, rnHsSigWcTypeScoped,
- rnLHsInstType,
newTyVarNameRn, collectAnonWildCards,
rnConDeclFields,
rnLTyVar,
@@ -323,12 +322,6 @@ rnImplicitBndrs bind_free_tvs doc
; bindLocalNamesFV vars $
thing_inside vars }
-rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars)
--- Rename the type in an instance or standalone deriving decl
--- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma"
--- Do not try to decompose the inst_ty in case it is malformed
-rnLHsInstType doc inst_ty = rnHsSigType (GenericCtx doc) inst_ty
-
mk_implicit_bndrs :: [Name] -- implicitly bound
-> a -- payload
-> FreeVars -- FreeVars of payload
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index 294b42c..35d95b9 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -607,13 +607,16 @@ deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)
-- This returns a Maybe because the user might try to derive Typeable, which is
-- a no-op nowadays.
deriveStandalone (L loc (DerivDecl deriv_ty deriv_strat' overlap_mode))
+ | let deriv_ty_no_wc = dropWildCards deriv_ty
+ -- dropWildCards; just awaiting the rest of Phab:D4383
= setSrcSpan loc $
- addErrCtxt (standaloneCtxt deriv_ty) $
+ addErrCtxt (standaloneCtxt deriv_ty_no_wc) $
do { traceTc "Standalone deriving decl for" (ppr deriv_ty)
; let deriv_strat = fmap unLoc deriv_strat'
; traceTc "Deriving strategy (standalone deriving)" $
vcat [ppr deriv_strat, ppr deriv_ty]
- ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt deriv_ty
+ ; (tvs, theta, cls, inst_tys) <- tcHsClsInstType TcType.InstDeclCtxt
+ deriv_ty_no_wc
; traceTc "Standalone deriving;" $ vcat
[ text "tvs:" <+> ppr tvs
, text "theta:" <+> ppr theta
More information about the ghc-commits
mailing list