Commit 0ee11df0 authored by simonpj's avatar simonpj
Browse files

[project @ 2004-12-24 11:02:39 by simonpj]

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.
parent fdba7999
......@@ -13,7 +13,8 @@ import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho )
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
)
......@@ -21,7 +22,7 @@ import TcHsSyn ( TcId, TcDictBinds, zonkId, mkHsLet )
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 )
......@@ -30,7 +31,7 @@ import TcHsType ( tcHsSigType, UserTypeCtxt(..), tcAddLetBoundTyVars,
)
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,
......@@ -442,10 +443,12 @@ tcMonoBinds binds lookup_sig is_rec
-- 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) }
......@@ -562,10 +565,18 @@ tcTySig (L span (Sig (L _ name) ty))
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
......
......@@ -26,11 +26,11 @@ import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2,
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,
......@@ -342,15 +342,23 @@ tcMethodBind inst_tyvars inst_theta avail_insts prags
-- 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
......@@ -360,20 +368,20 @@ tcMethodBind inst_tyvars inst_theta avail_insts prags
--
-- 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,
......@@ -397,19 +405,19 @@ tcMethodBind inst_tyvars inst_theta avail_insts 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
......
......@@ -56,7 +56,7 @@ import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType,
)
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 )
......@@ -248,21 +248,17 @@ tcExtendKindEnv things thing_inside
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
......@@ -347,17 +343,17 @@ find_thing ignore_it tidy_env (ATyVar tv ty)
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}
......
......@@ -11,6 +11,7 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where
#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 )
......@@ -36,19 +37,19 @@ import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMa
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,
......@@ -60,7 +61,6 @@ import CmdLineOpts
import HscTypes ( TyThing(..) )
import SrcLoc ( Located(..), unLoc, getLoc )
import Util
import Maybes ( catMaybes )
import Outputable
import FastString
......
......@@ -18,8 +18,7 @@ module TcHsType (
tcHsPatSigType, tcAddLetBoundTyVars,
TcSigInfo(..), mkTcSig,
TcSigFun, lookupSig
TcSigInfo(..), TcSigFun, lookupSig
) where
#include "HsVersions.h"
......@@ -33,21 +32,20 @@ import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
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 )
......@@ -150,6 +148,9 @@ the TyCon being defined.
\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
......@@ -391,7 +392,7 @@ kcTyVar name -- Could be a tyvar or a tycon
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
......@@ -501,8 +502,6 @@ ds_var_app name arg_tys
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}
......@@ -775,13 +774,42 @@ been instantiated.
\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
......@@ -793,21 +821,6 @@ lookupSig [] name = Nothing
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}
......
......@@ -16,7 +16,7 @@ import TcRnMonad
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 )
......
......@@ -18,6 +18,7 @@ import Inst ( InstOrigin(..),
instToId, tcInstStupidTheta, tcSyntaxName
)
import Id ( Id, idType, mkLocalId )
import Var ( tyVarName )
import Name ( Name )
import TcSimplify ( tcSimplifyCheck, bindInstsOfLocalFuns )
import TcEnv ( newLocalName, tcExtendIdEnv1, tcExtendTyVarEnv2,
......@@ -245,7 +246,7 @@ tc_pat ctxt (SigPatIn pat sig) pat_ty thing_inside
(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 $
......
......@@ -389,7 +389,7 @@ data TcTyThing
| 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
......
Supports Markdown
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