summaryrefslogtreecommitdiff
path: root/compiler/rename/RnSource.hs
diff options
context:
space:
mode:
authorSimon Peyton Jones <simonpj@microsoft.com>2015-12-01 17:38:23 +0100
committerBen Gamari <ben@smart-cactus.org>2015-12-01 18:45:23 +0100
commit1e041b7382b6aa329e4ad9625439f811e0f27232 (patch)
tree91f4418553a1e6df072f56f43b5697d40c985b5f /compiler/rename/RnSource.hs
parentb432e2f39c095d8acbb0cfcc63bd08436c7a3e49 (diff)
downloadhaskell-1e041b7382b6aa329e4ad9625439f811e0f27232.tar.gz
Refactor treatment of wildcards
This patch began as a modest refactoring of HsType and friends, to clarify and tidy up exactly where quantification takes place in types. Although initially driven by making the implementation of wildcards more tidy (and fixing a number of bugs), I gradually got drawn into a pretty big process, which I've been doing on and off for quite a long time. There is one compiler performance regression as a result of all this, in perf/compiler/T3064. I still need to look into that. * The principal driving change is described in Note [HsType binders] in HsType. Well worth reading! * Those data type changes drive almost everything else. In particular we now statically know where (a) implicit quantification only (LHsSigType), e.g. in instance declaratios and SPECIALISE signatures (b) implicit quantification and wildcards (LHsSigWcType) can appear, e.g. in function type signatures * As part of this change, HsForAllTy is (a) simplified (no wildcards) and (b) split into HsForAllTy and HsQualTy. The two contructors appear when and only when the correponding user-level construct appears. Again see Note [HsType binders]. HsExplicitFlag disappears altogether. * Other simplifications - ExprWithTySig no longer needs an ExprWithTySigOut variant - TypeSig no longer needs a PostRn name [name] field for wildcards - PatSynSig records a LHsSigType rather than the decomposed pieces - The mysterious 'GenericSig' is now 'ClassOpSig' * Renamed LHsTyVarBndrs to LHsQTyVars * There are some uninteresting knock-on changes in Haddock, because of the HsSyn changes I also did a bunch of loosely-related changes: * We already had type synonyms CoercionN/CoercionR for nominal and representational coercions. I've added similar treatment for TcCoercionN/TcCoercionR mkWpCastN/mkWpCastN All just type synonyms but jolly useful. * I record-ised ForeignImport and ForeignExport * I improved the (poor) fix to Trac #10896, by making TcTyClsDecls.checkValidTyCl recover from errors, but adding a harmless, abstract TyCon to the envt if so. * I did some significant refactoring in RnEnv.lookupSubBndrOcc, for reasons that I have (embarrassingly) now totally forgotten. It had to do with something to do with import and export Updates haddock submodule.
Diffstat (limited to 'compiler/rename/RnSource.hs')
-rw-r--r--compiler/rename/RnSource.hs234
1 files changed, 126 insertions, 108 deletions
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 1b234bd088..2fbbea4179 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -31,8 +31,7 @@ import Module
import HscTypes ( Warnings(..), plusWarns )
import Class ( FunDep )
import PrelNames ( applicativeClassName, pureAName, thenAName
- , monadClassName, returnMName, thenMName
- , isUnboundName )
+ , monadClassName, returnMName, thenMName )
import Name
import NameSet
import NameEnv
@@ -389,21 +388,26 @@ rnDefaultDecl (DefaultDecl tys)
-}
rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars)
-rnHsForeignDecl (ForeignImport name ty _ spec)
+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })
= do { topEnv :: HscEnv <- getTopEnv
; name' <- lookupLocatedTopBndrRn name
- ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
-- Mark any PackageTarget style imports as coming from the current package
; let unitId = thisPackage $ hsc_dflags topEnv
spec' = patchForeignImport unitId spec
- ; return (ForeignImport name' ty' noForeignImportCoercionYet spec', fvs) }
+ ; return (ForeignImport { fd_name = name', fd_sig_ty = ty'
+ , fd_co = noForeignImportCoercionYet
+ , fd_fi = spec' }, fvs) }
-rnHsForeignDecl (ForeignExport name ty _ spec)
+rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })
= do { name' <- lookupLocatedOccRn name
- ; (ty', fvs) <- rnLHsType (ForeignDeclCtx name) ty
- ; return (ForeignExport name' ty' noForeignExportCoercionYet spec, fvs `addOneFV` unLoc name') }
+ ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty
+ ; return (ForeignExport { fd_name = name', fd_sig_ty = ty'
+ , fd_co = noForeignExportCoercionYet
+ , fd_fe = spec }
+ , fvs `addOneFV` unLoc name') }
-- NB: a foreign export is an *occurrence site* for name, so
-- we add it to the free-variable list. It might, for example,
-- be imported from another module
@@ -464,7 +468,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid })
-- * Warn if 'pure' is defined backwards (i.e. @pure = return@).
-- * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).
--
-checkCanonicalMonadInstances :: Name -> LHsType Name -> LHsBinds Name -> RnM ()
+checkCanonicalMonadInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM ()
checkCanonicalMonadInstances cls poly_ty mbinds
| cls == applicativeClassName = do
forM_ (bagToList mbinds) $ \(L loc mbind) -> setSrcSpan loc $ do
@@ -524,11 +528,10 @@ checkCanonicalMonadInstances cls poly_ty mbinds
]
-- stolen from TcInstDcls
- instDeclCtxt1 :: LHsType Name -> SDoc
+ instDeclCtxt1 :: LHsSigType Name -> SDoc
instDeclCtxt1 hs_inst_ty
- = inst_decl_ctxt (case unLoc hs_inst_ty of
- HsForAllTy _ _ _ _ (L _ ty') -> ppr ty'
- _ -> ppr hs_inst_ty)
+ | (_, _, head_ty) <- splitLHsInstDeclTy hs_inst_ty
+ = inst_decl_ctxt (ppr head_ty)
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = hang (ptext (sLit "in the instance declaration for"))
@@ -540,23 +543,19 @@ 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 })
- -- Used for both source and interface file decls
- = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "In an instance declaration") inst_ty
- ; case splitLHsInstDeclTy_maybe inst_ty' of {
- Nothing -> return (ClsInstDecl { cid_poly_ty = inst_ty', cid_binds = emptyLHsBinds
- , cid_sigs = [], cid_tyfam_insts = []
- , cid_overlap_mode = oflag
- , cid_datafam_insts = [] }
- , inst_fvs) ;
- Just (inst_tyvars, _, L _ cls,_) ->
-
- do { let ktv_names = hsLKiTyVarNames inst_tyvars
-
- -- Rename the bindings
- -- The typechecker (not the renamer) checks that all
- -- the bindings are for the right class
- -- (Slightly strangely) when scoped type variables are on, the
- -- forall-d tyvars scope over the method bindings too
+ = do { (inst_ty', inst_fvs) <- rnLHsInstType (text "an instance declaration") inst_ty
+ ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'
+ ; let cls = case splitLHsClassTy_maybe head_ty' of
+ Nothing -> mkUnboundName (mkTcOccFS (fsLit "<class>"))
+ Just (L _ cls, _) -> cls
+ -- rnLHsInstType has added an error message
+ -- if splitLHsClassTy_maybe fails
+
+ -- Rename the bindings
+ -- The typechecker (not the renamer) checks that all
+ -- the bindings are for the right class
+ -- (Slightly strangely) when scoped type variables are on, the
+ -- forall-d tyvars scope over the method bindings too
; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags
; whenWOptM Opt_WarnNonCanonicalMonadInstances $
@@ -564,11 +563,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
-- Rename the associated types, and type signatures
-- Both need to have the instance type variables in scope
- ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr inst_tyvars $$ ppr ktv_names)
+ ; traceRn (text "rnSrcInstDecl" <+> ppr inst_ty' $$ ppr ktv_names)
; ((ats', adts'), more_fvs)
<- extendTyVarEnvFVRn ktv_names $
- do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls inst_tyvars ats
- ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls inst_tyvars adts
+ do { (ats', at_fvs) <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats
+ ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts
; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }
; let all_fvs = meth_fvs `plusFV` more_fvs
@@ -577,7 +576,7 @@ 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' },
- all_fvs) } } }
+ all_fvs) }
-- We return the renamed associated data type declarations so
-- that they can be entered into the list of type declarations
-- for the binding group, but we also keep a copy in the instance.
@@ -592,12 +591,11 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds
rnFamInstDecl :: HsDocContext
-> Maybe (Name, [Name])
-> Located RdrName
- -> [LHsType RdrName]
+ -> HsTyPats RdrName
-> rhs
-> (HsDocContext -> rhs -> RnM (rhs', FreeVars))
- -> RnM (Located Name, HsWithBndrs Name [LHsType Name], rhs',
- FreeVars)
-rnFamInstDecl doc mb_cls tycon pats payload rnPayload
+ -> RnM (Located Name, HsTyPats Name, rhs', FreeVars)
+rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload
= do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon
; let loc = case pats of
[] -> pprPanic "rnFamInstDecl" (ppr tycon)
@@ -605,7 +603,6 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
(L loc _ : ps) -> combineSrcSpans loc (getLoc (last ps))
(kv_rdr_names, tv_rdr_names) = extractHsTysRdrTyVars pats
-
; rdr_env <- getLocalRdrEnv
; kv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) kv_rdr_names
; tv_names <- mapM (newTyVarNameRn mb_cls rdr_env loc) tv_rdr_names
@@ -614,7 +611,7 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
; ((pats', payload'), fvs)
<- bindLocalNamesFV kv_names $
bindLocalNamesFV tv_names $
- do { (pats', pat_fvs) <- rnLHsTypes doc pats
+ do { (pats', pat_fvs) <- rnLHsTypes (FamPatCtx tycon) pats
; (payload', rhs_fvs) <- rnPayload doc payload
-- See Note [Renaming associated types]
@@ -631,19 +628,12 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload
; let all_fvs = fvs `addOneFV` unLoc tycon'
- awcs = concatMap collectAnonymousWildCardNames pats'
; return (tycon',
- HsWB { hswb_cts = pats', hswb_kvs = kv_names,
- hswb_tvs = tv_names, hswb_wcs = awcs },
+ HsIB { hsib_body = pats'
+ , hsib_kvs = kv_names, hsib_tvs = tv_names },
payload',
all_fvs) }
-- type instance => use, hence addOneFV
- where
- collectAnonymousWildCardNames ty
- = [ wildCardName wc
- | L _ wc <- snd (collectWildCards ty)
- , isAnonWildCard wc ]
-
rnTyFamInstDecl :: Maybe (Name, [Name])
-> TyFamInstDecl RdrName
@@ -657,7 +647,7 @@ rnTyFamInstEqn :: Maybe (Name, [Name])
-> TyFamInstEqn RdrName
-> RnM (TyFamInstEqn Name, FreeVars)
rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon
- , tfe_pats = HsWB { hswb_cts = pats }
+ , tfe_pats = pats
, tfe_rhs = rhs })
= do { (tycon', pats', rhs', fvs) <-
rnFamInstDecl (TySynCtx tycon) mb_cls tycon pats rhs rnTySyn
@@ -671,7 +661,7 @@ rnTyFamDefltEqn :: Name
rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon
, tfe_pats = tyvars
, tfe_rhs = rhs })
- = bindHsTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
+ = bindHsQTyVars ctx (Just cls) [] tyvars $ \ tyvars' ->
do { tycon' <- lookupFamInstName (Just cls) tycon
; (rhs', fvs) <- rnLHsType ctx rhs
; return (TyFamEqn { tfe_tycon = tycon'
@@ -684,7 +674,7 @@ rnDataFamInstDecl :: Maybe (Name, [Name])
-> DataFamInstDecl RdrName
-> RnM (DataFamInstDecl Name, FreeVars)
rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon
- , dfid_pats = HsWB { hswb_cts = pats }
+ , dfid_pats = pats
, dfid_defn = defn })
= do { (tycon', pats', defn', fvs) <-
rnFamInstDecl (TyDataCtx tycon) mb_cls tycon pats defn rnDataDefn
@@ -706,7 +696,7 @@ rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
decl RdrName -> -- an instance. rnTyFamInstDecl
RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl
-> Name -- Class
- -> LHsTyVarBndrs Name
+ -> [Name]
-> [Located (decl RdrName)]
-> RnM ([Located (decl Name)], FreeVars)
-- Used for data and type family defaults in a class decl
@@ -714,10 +704,8 @@ rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames
--
-- NB: We allow duplicate associated-type decls;
-- See Note [Associated type instances] in TcInstDcls
-rnATInstDecls rnFun cls hs_tvs at_insts
+rnATInstDecls rnFun cls tv_ns at_insts
= rnList (rnFun (Just (cls, tv_ns))) at_insts
- where
- tv_ns = hsLKiTyVarNames hs_tvs
-- See Note [Renaming associated types]
{-
@@ -813,7 +801,7 @@ bindHsRuleVars rule_name vars names thing_inside
thing_inside (L l (RuleBndr (L loc n)) : vars')
go (L l (RuleBndrSig (L loc _) bsig) : vars) (n : ns) thing_inside
- = rnHsBndrSig doc bsig $ \ bsig' ->
+ = rnHsSigWcTypeScoped doc bsig $ \ bsig' ->
go vars ns $ \ vars' ->
thing_inside (L l (RuleBndrSig (L loc n) bsig') : vars')
@@ -940,7 +928,7 @@ rnHsVectDecl (HsVectClassIn s cls)
rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn instTy)
- = do { (instTy', fvs) <- rnLHsInstType (text "In a VECTORISE pragma") instTy
+ = do { (instTy', fvs) <- rnLHsInstType (text "a VECTORISE pragma") instTy
; return (HsVectInstIn instTy', fvs)
}
rnHsVectDecl (HsVectInstOut _)
@@ -1082,7 +1070,7 @@ rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdRhs = rhs })
; let kvs = fst (extractHsTyRdrTyVars rhs)
doc = TySynCtx tycon
; traceRn (text "rntycl-ty" <+> ppr tycon <+> ppr kvs)
- ; ((tyvars', rhs'), fvs) <- bindHsTyVars doc Nothing kvs tyvars $
+ ; ((tyvars', rhs'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $
\ tyvars' ->
do { (rhs', fvs) <- rnTySyn doc rhs
; return ((tyvars', rhs'), fvs) }
@@ -1096,17 +1084,16 @@ rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars, tcdDataDefn = defn
; let kvs = extractDataDefnKindVars defn
doc = TyDataCtx tycon
; traceRn (text "rntycl-data" <+> ppr tycon <+> ppr kvs)
- ; ((tyvars', defn'), fvs) <-
- bindHsTyVars doc Nothing kvs tyvars $ \ tyvars' ->
+ ; ((tyvars', defn'), fvs) <- bindHsQTyVars doc Nothing kvs tyvars $ \ tyvars' ->
do { (defn', fvs) <- rnDataDefn doc defn
; return ((tyvars', defn'), fvs) }
; return (DataDecl { tcdLName = tycon', tcdTyVars = tyvars'
, tcdDataDefn = defn', tcdFVs = fvs }, fvs) }
-rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
- tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
- tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
- tcdDocs = docs})
+rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,
+ tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs,
+ tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,
+ tcdDocs = docs})
= do { lcls' <- lookupLocatedTopBndrRn lcls
; let cls' = unLoc lcls'
kvs = [] -- No scoped kind vars except those in
@@ -1114,7 +1101,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- Tyvars scope over superclass context and method signatures
; ((tyvars', context', fds', ats'), stuff_fvs)
- <- bindHsTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
+ <- bindHsQTyVars cls_doc Nothing kvs tyvars $ \ tyvars' -> do
-- Checks for distinct tyvars
{ (context', cxt_fvs) <- rnContext cls_doc context
; fds' <- rnFds fds
@@ -1131,7 +1118,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = lcls,
-- Check the signatures
-- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).
- ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _ _) <- sigs, op <- ops]
+ ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs
+ , op <- ops]
; checkDupRdrNames sig_rdr_names_w_locs
-- Typechecker is responsible for checking that we only
-- give default-method bindings for things in this class.
@@ -1257,9 +1245,11 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType
L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False
_ -> True
- rn_derivs Nothing = return (Nothing, emptyFVs)
- rn_derivs (Just (L ld ds)) = do { (ds', fvs) <- rnLHsTypes doc ds
- ; return (Just (L ld ds'), fvs) }
+ rn_derivs Nothing
+ = return (Nothing, emptyFVs)
+ rn_derivs (Just (L loc ds))
+ = do { (ds', fvs) <- mapFvRn (rnHsSigType doc) ds
+ ; return (Just (L loc ds'), fvs) }
badGadtStupidTheta :: HsDocContext -> SDoc
badGadtStupidTheta _
@@ -1276,7 +1266,7 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars
, fdInjectivityAnn = injectivity })
= do { tycon' <- lookupLocatedTopBndrRn tycon
; ((tyvars', res_sig', injectivity'), fv1) <-
- bindHsTyVars doc mb_cls kvs tyvars $ \ tyvars' ->
+ bindHsQTyVars doc mb_cls kvs tyvars $ \ tyvars' ->
do { (res_sig', fv_kind) <- wrapLocFstM (rnFamResultSig doc) res_sig
; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')
injectivity
@@ -1369,7 +1359,7 @@ rnFamResultSig doc (TyVarSig tvbndr)
-- | Rename injectivity annotation. Note that injectivity annotation is just the
-- part after the "|". Everything that appears before it is renamed in
-- rnFamDecl.
-rnInjectivityAnn :: LHsTyVarBndrs Name -- ^ Type variables declared in
+rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in
-- type family head
-> LFamilyResultSig Name -- ^ Result signature
-> LInjectivityAnn RdrName -- ^ Injectivity annotation
@@ -1382,8 +1372,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
bindLocalNames [hsLTyVarName resTv] $
-- The return type variable scopes over the injectivity annotation
-- e.g. type family F a = (r::*) | r -> a
- do { injFrom' <- rnLTyVar True injFrom
- ; injTo' <- mapM (rnLTyVar True) injTo
+ do { injFrom' <- rnLTyVar injFrom
+ ; injTo' <- mapM rnLTyVar injTo
; return $ L srcSpan (InjectivityAnn injFrom' injTo') }
; let tvNames = Set.fromList $ hsLKiTyVarNames tvBndrs
@@ -1423,8 +1413,8 @@ rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv))
rnInjectivityAnn _ _ (L srcSpan (InjectivityAnn injFrom injTo)) =
setSrcSpan srcSpan $ do
(injDecl', _) <- askNoErrs $ do
- injFrom' <- rnLTyVar True injFrom
- injTo' <- mapM (rnLTyVar True) injTo
+ injFrom' <- rnLTyVar injFrom
+ injTo' <- mapM rnLTyVar injTo
return $ L srcSpan (InjectivityAnn injFrom' injTo')
return $ injDecl'
@@ -1516,6 +1506,29 @@ modules), we get better error messages, too.
\subsection{Support code for type/data declarations}
* *
*********************************************************
+
+Note [Quantification in data constructor declarations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Four cases, afer renaming
+ * ResTyH98
+ - data T a = forall b. MkT { x :: b -> a }
+ The 'b' is explicitly declared;
+ con_qvars = [b]
+
+ - data T a = MkT { x :: a -> b }
+ Do *not* implicitly quantify over 'b'; it is
+ simply out of scope. con_qvars = []
+
+ * ResTyGADT
+ - data T a where { MkT :: forall b. (b -> a) -> T a }
+ con_qvars = [a,b]
+
+ - data T a where { MkT :: (b -> a) -> T a }
+ con_qvars = [a,b], by implicit quantification
+ of the type signature
+ It is uncomfortable that we add implicitly-bound
+ type variables to the HsQTyVars, which usually
+ only has explicitly-bound type variables
-}
---------------
@@ -1530,49 +1543,53 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars)
rnConDecls = mapFvRn (wrapLocFstM rnConDecl)
rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars)
-rnConDecl decl@(ConDecl { con_names = names, con_qvars = tvs
+rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs
, con_cxt = lcxt@(L loc cxt), con_details = details
, con_res = res_ty, con_doc = mb_doc
- , con_explicit = expl })
+ , con_explicit = explicit })
= do { mapM_ (addLocM checkConName) names
- ; new_names <- mapM lookupLocatedTopBndrRn names
-
- -- For H98 syntax, the tvs are the existential ones
- -- For GADT syntax, the tvs are all the quantified tyvars
- -- Hence the 'filter' in the ResTyH98 case only
- ; rdr_env <- getLocalRdrEnv
- ; let arg_tys = hsConDeclArgTys details
- (free_kvs, free_tvs) = case res_ty of
- ResTyH98 -> filterInScope rdr_env (get_rdr_tvs arg_tys)
- ResTyGADT _ ty -> get_rdr_tvs (ty : arg_tys)
-
- -- With an Explicit forall, check for unused binders
- -- With Implicit, find the mentioned ones, and use them as binders
- -- With Qualified, do the same as with Implicit, but give a warning
- -- See Note [Context quantification]
- ; new_tvs <- case expl of
- Implicit -> return (mkHsQTvs (userHsTyVarBndrs loc free_tvs))
- Qualified -> do { warnContextQuantification (docOfHsDocContext doc)
- (userHsTyVarBndrs loc free_tvs)
- ; return (mkHsQTvs (userHsTyVarBndrs loc free_tvs)) }
- Explicit -> do { warnUnusedForAlls (docOfHsDocContext doc) tvs free_tvs
- ; return tvs }
-
- ; mb_doc' <- rnMbLHsDoc mb_doc
-
- ; bindHsTyVars doc Nothing free_kvs new_tvs $ \new_tyvars -> do
+ ; new_names <- mapM lookupLocatedTopBndrRn names
+ ; mb_doc' <- rnMbLHsDoc mb_doc
+ ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) res_ty
+
+ ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do
{ (new_context, fvs1) <- rnContext doc lcxt
; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details
; (new_details', new_res_ty, fvs3)
<- rnConResult doc (map unLoc new_names) new_details res_ty
+ ; traceRn (text "rnConDecl" <+> ppr names <+> vcat
+ [ text "free_kvs:" <+> ppr kvs
+ , text "qtvs:" <+> ppr qtvs
+ , text "qtvs':" <+> ppr qtvs' ])
+ ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+ ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs
; return (decl { con_names = new_names, con_qvars = new_tyvars
, con_cxt = new_context, con_details = new_details'
, con_res = new_res_ty, con_doc = mb_doc' },
- fvs1 `plusFV` fvs2 `plusFV` fvs3) }}
+ all_fvs) }}
where
doc = ConDeclCtx names
get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys)
+ get_con_qtvs :: LHsQTyVars RdrName -> [LHsType RdrName]
+ -> ResType (LHsType RdrName)
+ -> ([RdrName], LHsQTyVars RdrName)
+ get_con_qtvs qtvs arg_tys ResTyH98
+ | explicit -- data T = forall a. MkT (a -> a)
+ = (free_kvs, qtvs)
+ | otherwise -- data T = MkT (a -> a)
+ = ([], mkHsQTvs [])
+ where
+ (free_kvs, _) = get_rdr_tvs arg_tys
+
+ get_con_qtvs qtvs arg_tys (ResTyGADT _ ty)
+ | explicit -- data T x where { MkT :: forall a. a -> T a }
+ = (free_kvs, qtvs)
+ | otherwise -- data T x where { MkT :: a -> T a }
+ = (free_kvs, mkHsQTvs (userHsTyVarBndrs loc free_tvs))
+ where
+ (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys)
+
rnConResult :: HsDocContext -> [Name]
-> HsConDetails (LHsType Name) (Located [LConDeclField Name])
-> ResType (LHsType RdrName)
@@ -1591,7 +1608,7 @@ rnConResult doc _con details (ResTyGADT ls ty)
-- See Note [Sorting out the result type] in RdrHsSyn
RecCon {} -> do { unless (null arg_tys)
- (addErr (badRecResTy (docOfHsDocContext doc)))
+ (addErr (badRecResTy doc))
; return (details, ResTyGADT ls res_ty, fvs) }
PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)}
@@ -1618,8 +1635,9 @@ rnConDeclDetails con doc (RecCon (L l fields))
; return (RecCon (L l new_fields), fvs) }
-------------------------------------------------
-badRecResTy :: SDoc -> SDoc
-badRecResTy doc = ptext (sLit "Malformed constructor signature") $$ doc
+badRecResTy :: HsDocContext -> SDoc
+badRecResTy ctxt = withHsDocContext ctxt $
+ ptext (sLit "Malformed constructor signature")
-- | Brings pattern synonym names and also pattern synonym selectors
-- from record pattern synonyms into scope.