Further wibbles to the scoped-tyvar story.
This commit tidies up the ATyVar in TcTyThing, making it
ATyVar Name Type
instead of the previous misleading
ATyVar TyVar Type
But the main thing is that we must take care with definitions
like this:
type T a = forall b. b -> (a,b)
f :: forall c. T c
f = ...
Here, we want only 'c' to scope over the RHS of f. The renamer ensures
that... but we must also take care that we freshly instantiate the
expanded type signature (forall c b. b -> (c,b)) before checking f's RHS,
so that we don't get false sharing between uses of T.
import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) )
import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
- LSig, Match(..), HsBindGroup(..), IPBind(..),
+ LSig, Match(..), HsBindGroup(..), IPBind(..),
+ HsType(..), hsLTyVarNames,
LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
collectHsBindBinders, collectPatBinders, pprPatBind
)
import TcRnMonad
import Inst ( InstOrigin(..), newDictsAtLoc, newIPDict, instToId )
-import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv, newLocalName, tcLookupLocalIds )
+import TcEnv ( tcExtendIdEnv, tcExtendIdEnv2, tcExtendTyVarEnv2, newLocalName, tcLookupLocalIds )
import TcUnify ( Expected(..), tcInfer, checkSigTyVars, sigCtxt )
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted,
tcSimplifyToDicts, tcSimplifyIPs )
)
import TcPat ( tcPat, PatCtxt(..) )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcMType ( newTyFlexiVarTy, tcSkolSigType, zonkQuantifiedTyVar, zonkTcTypes )
+import TcMType ( newTyFlexiVarTy, tcSkolType, zonkQuantifiedTyVar, zonkTcTypes )
import TcType ( TcTyVar, SkolemInfo(SigSkol),
TcTauType, TcSigmaType,
TvSubstEnv, mkTvSubst, substTheta, substTy,
-- though each type sig should scope only over its own RHS,
-- because the renamer has sorted all that out.
; let mono_info = getMonoBindInfo tc_binds
- rhs_tvs = [ tv | (_, Just sig, _) <- mono_info, tv <- sig_tvs sig ]
+ rhs_tvs = [ (name, mkTyVarTy tv)
+ | (_, Just sig, _) <- mono_info,
+ (name, tv) <- sig_scoped sig `zip` sig_tvs sig ]
rhs_id_env = map mk mono_info -- A binding for each term variable
- ; binds' <- tcExtendTyVarEnv rhs_tvs $
+ ; binds' <- tcExtendTyVarEnv2 rhs_tvs $
tcExtendIdEnv2 rhs_id_env $
mapBagM (wrapLocM tcRhs) tc_binds
; return (binds', mono_info) }
do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
; let rigid_info = SigSkol name
poly_id = mkLocalId name sigma_ty
- ; (tvs, theta, tau) <- tcSkolSigType rigid_info sigma_ty
+
+ -- The scoped names are the ones explicitly mentioned
+ -- in the HsForAll. (There may be more in sigma_ty, because
+ -- of nested type synonyms. See Note [Scoped] with TcSigInfo.)
+ scoped_names = case ty of
+ L _ (HsForAllTy _ tvs _ _) -> hsLTyVarNames tvs
+ other -> []
+
+ ; (tvs, theta, tau) <- tcSkolType rigid_info sigma_ty
; loc <- getInstLoc (SigOrigin rigid_info)
- ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tvs,
- sig_theta = theta, sig_tau = tau,
+ ; return (TcSigInfo { sig_id = poly_id, sig_scoped = scoped_names,
+ sig_tvs = tvs, sig_theta = theta, sig_tau = tau,
sig_loc = loc }) }
checkSigCtxt :: TcSigInfo -> TcSigInfo -> TcM TcSigInfo
InstBindings(..), newDFunName
)
import TcBinds ( tcMonoBinds, tcSpecSigs )
-import TcHsType ( TcSigInfo(..), mkTcSig, tcHsKindedType, tcHsSigType )
+import TcHsType ( TcSigInfo(..), tcHsKindedType, tcHsSigType )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcUnify ( checkSigTyVars, sigCtxt )
-import TcMType ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ) )
-import TcType ( Type, SkolemInfo(ClsSkol, InstSkol),
+import TcMType ( tcSkolSigTyVars, UserTypeCtxt( GenPatCtxt ), tcSkolType )
+import TcType ( Type, SkolemInfo(ClsSkol, InstSkol, SigSkol),
TcType, TcThetaType, TcTyVar, mkTyVarTys,
mkClassPred, tcSplitSigmaTy, tcSplitFunTys,
tcIsTyVarTy, tcSplitTyConApp_maybe, tcSplitForAllTys, tcSplitPhiTy,
-- Check the bindings; first adding inst_tyvars to the envt
-- so that we don't quantify over them in nested places
- mkTcSig meth_id `thenM` \ meth_sig ->
- let lookup_sig name = ASSERT( name == idName meth_id )
- Just meth_sig
- in
- tcExtendTyVarEnv inst_tyvars (
+
+
+ let -- Fake up a TcSigInfo to pass to tcMonoBinds
+ rigid_info = SigSkol (idName meth_id)
+ in
+ tcSkolType rigid_info (idType meth_id) `thenM` \ (tyvars', theta', tau') ->
+ getInstLoc (SigOrigin rigid_info) `thenM` \ loc ->
+ let meth_sig = TcSigInfo { sig_id = meth_id, sig_tvs = tyvars', sig_scoped = [],
+ sig_theta = theta', sig_tau = tau', sig_loc = loc }
+ lookup_sig name = ASSERT( name == idName meth_id )
+ Just meth_sig
+ in
+ tcExtendTyVarEnv inst_tyvars (
addErrCtxt (methodCtxt sel_id) $
getLIE $
tcMonoBinds (unitBag meth_bind) lookup_sig NonRecursive
- ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
+ ) `thenM` \ ((meth_bind, mono_bind_infos), meth_lie) ->
-- Now do context reduction. We simplify wrt both the local tyvars
-- and the ones of the class/instance decl, so that there is
--
-- We do this for each method independently to localise error messages
- addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
- newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts ->
- let
+ addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $
+ newDictsAtLoc (sig_loc meth_sig) (sig_theta meth_sig) `thenM` \ meth_dicts ->
+ let
meth_tvs = sig_tvs meth_sig
all_tyvars = meth_tvs ++ inst_tyvars
all_insts = avail_insts ++ meth_dicts
- in
- tcSimplifyCheck
+ in
+ tcSimplifyCheck
(ptext SLIT("class or instance method") <+> quotes (ppr sel_id))
all_tyvars all_insts meth_lie `thenM` \ lie_binds ->
- checkSigTyVars all_tyvars `thenM_`
+ checkSigTyVars all_tyvars `thenM_`
- let
+ let
sel_name = idName sel_id
inline_prags = [ (is_inl, phase)
| L _ (InlineSig is_inl (L _ name) phase) <- prags,
inlines
(lie_binds `unionBags` meth_bind)
- in
+ in
-- Deal with specialisation pragmas
-- The sel_name is what appears in the pragma
- tcExtendIdEnv2 [(sel_name, final_meth_id)] (
+ tcExtendIdEnv2 [(sel_name, final_meth_id)] (
getLIE (tcSpecSigs spec_prags) `thenM` \ (spec_binds1, prag_lie) ->
-- The prag_lie for a SPECIALISE pragma will mention the function itself,
-- so we have to simplify them away right now lest they float outwards!
bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 ->
returnM (spec_binds1 `unionBags` spec_binds2)
- ) `thenM` \ spec_binds ->
+ ) `thenM` \ spec_binds ->
- returnM (poly_meth_bind `consBag` spec_binds)
+ returnM (poly_meth_bind `consBag` spec_binds)
mkMethodBind :: InstOrigin
)
import qualified Type ( getTyVar_maybe )
import Id ( idName, isLocalId )
-import Var ( TyVar, Id, idType )
+import Var ( TyVar, Id, idType, tyVarName )
import VarSet
import VarEnv
import RdrName ( extendLocalRdrEnv )
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
- = tc_extend_tv_env [ATyVar tv (mkTyVarTy tv) | tv <- tvs] thing_inside
+ = tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
-tcExtendTyVarEnv2 :: [(TyVar,TcType)] -> TcM r -> TcM r
-tcExtendTyVarEnv2 ty_pairs thing_inside
- = tc_extend_tv_env [ATyVar tv1 ty2 | (tv1,ty2) <- ty_pairs] thing_inside
-
-tc_extend_tv_env binds thing_inside
+tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
+tcExtendTyVarEnv2 binds thing_inside
= getLclEnv `thenM` \ env@(TcLclEnv {tcl_env = le,
tcl_tyvars = gtvs,
tcl_rdr = rdr_env}) ->
let
- names = [getName tv | ATyVar tv _ <- binds]
- rdr_env' = extendLocalRdrEnv rdr_env names
- le' = extendNameEnvList le (names `zip` binds)
- new_tv_set = tyVarsOfTypes [ty | ATyVar _ ty <- binds]
+ rdr_env' = extendLocalRdrEnv rdr_env (map fst binds)
+ new_tv_set = tyVarsOfTypes (map snd binds)
+ le' = extendNameEnvList le [(name, ATyVar name ty) | (name, ty) <- binds]
in
-- It's important to add the in-scope tyvars to the global tyvar set
-- as well. Consider
if ignore_it tv_ty then
returnM (tidy_env, Nothing)
else let
- (tidy_env1, tv1) = tidyOpenTyVar tidy_env tv
- (tidy_env2, tidy_ty) = tidyOpenType tidy_env1 tv_ty
- msg = sep [ppr tv1 <+> eq_stuff, nest 2 bound_at]
+ -- The name tv is scoped, so we don't need to tidy it
+ (tidy_env1, tidy_ty) = tidyOpenType tidy_env tv_ty
+ msg = sep [ppr tv <+> eq_stuff, nest 2 bound_at]
eq_stuff | Just tv' <- Type.getTyVar_maybe tv_ty,
- tv == tv' = empty
+ tv == tyVarName tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
bound_at = ptext SLIT("bound at:") <+> ppr (getSrcLoc tv)
in
- returnM (tidy_env2, Just msg)
+ returnM (tidy_env1, Just msg)
\end{code}
#ifdef GHCI /* Only if bootstrapped */
import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket )
import Id ( Id )
+import Name ( isExternalName )
import TcType ( isTauTy )
import TcEnv ( checkWellStaged )
import HsSyn ( nlHsApp )
import TcHsType ( tcHsSigType, UserTypeCtxt(..) )
import TcPat ( badFieldCon, refineTyVars )
import TcMType ( tcInstTyVars, tcInstType, newTyFlexiVarTy, zonkTcType )
-import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType, MetaDetails(..),
+import TcType ( Type, TcTyVar, TcType, TcSigmaType, TcRhoType,
tcSplitFunTys, tcSplitTyConApp, mkTyVarTys,
isSigmaTy, mkFunTy, mkTyConApp, tyVarsOfTypes, isLinearPred,
tcSplitSigmaTy, tidyOpenType
)
import Kind ( openTypeKind, liftedTypeKind, argTypeKind )
-import Id ( idType, recordSelectorFieldLabel, isRecordSelector, idName )
+import Id ( idType, recordSelectorFieldLabel, isRecordSelector )
import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
-import Name ( Name, isExternalName )
+import Name ( Name )
import TyCon ( TyCon, FieldLabel, tyConTyVars, tyConStupidTheta,
tyConDataCons, tyConFields )
-import Type ( zipTopTvSubst, mkTopTvSubst, substTheta, substTy )
+import Type ( zipTopTvSubst, substTheta, substTy )
import VarSet ( emptyVarSet, elemVarSet )
import TysWiredIn ( boolTy, parrTyCon, tupleTyCon )
import PrelNames ( enumFromName, enumFromThenName,
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
-import Maybes ( catMaybes )
import Outputable
import FastString
tcHsPatSigType, tcAddLetBoundTyVars,
- TcSigInfo(..), mkTcSig,
- TcSigFun, lookupSig
+ TcSigInfo(..), TcSigFun, lookupSig
) where
#include "HsVersions.h"
tcLookup, tcLookupClass, tcLookupTyCon,
TyThing(..), getInLocalScope, wrongThingErr
)
-import TcMType ( newKindVar, tcSkolType, newMetaTyVar,
- zonkTcKindToKind,
+import TcMType ( newKindVar, newMetaTyVar, zonkTcKindToKind,
checkValidType, UserTypeCtxt(..), pprHsSigCtxt
)
import TcUnify ( unifyFunKind, checkExpectedKind )
import TcType ( Type, PredType(..), ThetaType,
- SkolemInfo(SigSkol), MetaDetails(Flexi),
+ MetaDetails(Flexi),
TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
mkForAllTys, mkFunTys, tcEqType, isPredTy, mkFunTy,
mkSigmaTy, mkPredTy, mkGenTyConApp, mkTyConApp, mkAppTys,
- tcSplitFunTy_maybe, tcSplitForAllTys )
+ tcSplitFunTy_maybe, tcSplitForAllTys, typeKind )
import Kind ( Kind, isLiftedTypeKind, liftedTypeKind, ubxTupleKind,
openTypeKind, argTypeKind, splitKindFunTys )
-import Id ( idName, idType )
-import Var ( TyVar, mkTyVar, tyVarKind )
+import Id ( idName )
+import Var ( TyVar, mkTyVar )
import TyCon ( TyCon, tyConKind )
import Class ( Class, classTyCon )
import Name ( Name, mkInternalName )
\begin{code}
tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type
-- Do kind checking, and hoist for-alls to the top
+ -- NB: it's important that the foralls that come from the top-level
+ -- HsForAllTy in hs_ty occur *first* in the returned type.
+ -- See Note [Scoped] with TcSigInfo
tcHsSigType ctxt hs_ty
= addErrCtxt (pprHsSigCtxt ctxt hs_ty) $
do { kinded_ty <- kcTypeType hs_ty
tcLookup name `thenM` \ thing ->
traceTc (text "lk2" <+> ppr name <+> ppr thing) `thenM_`
case thing of
- ATyVar tv _ -> returnM (tyVarKind tv)
+ ATyVar _ ty -> returnM (typeKind ty)
AThing kind -> returnM kind
AGlobal (ATyCon tc) -> returnM (tyConKind tc)
other -> wrongThingErr "type" thing name
case thing of
ATyVar _ ty -> returnM (mkAppTys ty arg_tys)
AGlobal (ATyCon tc) -> returnM (mkGenTyConApp tc arg_tys)
--- AThing _ -> tcLookupTyCon name `thenM` \ tc ->
--- returnM (mkGenTyConApp tc arg_tys)
other -> pprPanic "ds_app_type" (ppr name <+> ppr arg_tys)
\end{code}
\begin{code}
data TcSigInfo
= TcSigInfo {
- sig_id :: TcId, -- *Polymorphic* binder for this value...
- sig_tvs :: [TcTyVar], -- tyvars
- sig_theta :: TcThetaType, -- theta
- sig_tau :: TcTauType, -- tau
- sig_loc :: InstLoc -- The location of the signature
+ sig_id :: TcId, -- *Polymorphic* binder for this value...
+
+ sig_scoped :: [Name], -- Names for any scoped type variables
+ -- Invariant: correspond 1-1 with an initial
+ -- segment of sig_tvs (see Note [Scoped])
+
+ sig_tvs :: [TcTyVar], -- Instantiated type variables
+ -- See Note [Instantiate sig]
+
+ sig_theta :: TcThetaType, -- Instantiated theta
+ sig_tau :: TcTauType, -- Instantiated tau
+ sig_loc :: InstLoc -- The location of the signature
}
+-- Note [Scoped]
+-- There may be more instantiated type variables than scoped
+-- ones. For example:
+-- type T a = forall b. b -> (a,b)
+-- f :: forall c. T c
+-- Here, the signature for f will have one scoped type variable, c,
+-- but two instantiated type variables, c' and b'.
+--
+-- We assume that the scoped ones are at the *front* of sig_tvs,
+-- and remember the names from the original HsForAllTy in sig_scoped
+
+-- Note [Instantiate sig]
+-- It's vital to instantiate a type signature with fresh variable.
+-- For example:
+-- type S = forall a. a->a
+-- f,g :: S
+-- f = ...
+-- g = ...
+-- Here, we must use distinct type variables when checking f,g's right hand sides.
+-- (Instantiation is only necessary because of type synonyms. Otherwise,
+-- it's all cool; each signature has distinct type variables from the renamer.)
+
type TcSigFun = Name -> Maybe TcSigInfo
instance Outputable TcSigInfo where
lookupSig (sig : sigs) name
| name == idName (sig_id sig) = Just sig
| otherwise = lookupSig sigs name
-
-mkTcSig :: TcId -> TcM TcSigInfo
-mkTcSig poly_id
- = -- Instantiate this type
- -- It's important to do this even though in the error-free case
- -- we could just split the sigma_tc_ty (since the tyvars don't
- -- unified with anything). But in the case of an error, when
- -- the tyvars *do* get unified with something, we want to carry on
- -- typechecking the rest of the program with the function bound
- -- to a pristine type, namely sigma_tc_ty
- do { let rigid_info = SigSkol (idName poly_id)
- ; (tyvars', theta', tau') <- tcSkolType rigid_info (idType poly_id)
- ; loc <- getInstLoc (SigOrigin rigid_info)
- ; return (TcSigInfo { sig_id = poly_id, sig_tvs = tyvars',
- sig_theta = theta', sig_tau = tau', sig_loc = loc }) }
\end{code}
import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeErr,
checkAmbiguity, SourceTyCtxt(..) )
import TcType ( mkClassPred, tyVarsOfType,
- tcSplitSigmaTy, getClassPredTys, tcSplitDFunHead, mkTyVarTys,
+ tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys,
SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred )
import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv )
import TcDeriv ( tcDeriving )
instToId, tcInstStupidTheta, tcSyntaxName
)
import Id ( Id, idType, mkLocalId )
+import Var ( tyVarName )
import Name ( Name )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
(sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig
; tcSubPat sig_ty pat_ty
; subst <- refineTyVars sig_tvs -- See note [Type matching]
- ; let tv_binds = [(tv, substTyVar subst tv) | tv <- sig_tvs]
+ ; let tv_binds = [(tyVarName tv, substTyVar subst tv) | tv <- sig_tvs]
sig_ty' = substTy subst sig_ty
; (pat', tvs, res)
<- tcExtendTyVarEnv2 tv_binds $
| ATcId TcId ThLevel ProcLevel -- Ids defined in this module; may not be fully zonked
- | ATyVar TyVar TcType -- Type variables; tv -> type. It can't just be a TyVar
+ | ATyVar Name TcType -- Type variables; tv -> type. It can't just be a TyVar
-- that is mutated to point to the type it is bound to,
-- because that would make it a wobbly type, and we
-- want pattern-bound lexically-scoped type variables to
projects / ghc-hetmet.git / commitdiff