Commit a2fe5d21 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Change ATyVar to only have a *tyvar* not a *type* in it

This isn't really a forced change, but is a useful tidy-up
parent 384c3864
......@@ -399,7 +399,7 @@ tcPolyCheck sig@(TcSigInfo { sig_id = poly_id, sig_tvs = tvs, sig_scoped = scope
prag_sigs = prag_fn (idName poly_id)
; (ev_binds, (binds', [mono_info]))
<- checkConstraints skol_info tvs ev_vars $
tcExtendTyVarEnv2 (scoped `zip` mkTyVarTys tvs) $
tcExtendTyVarEnv2 (scoped `zip` tvs) $
tcMonoBinds (\_ -> Just sig) LetLclBndr rec_tc bind_list
; spec_prags <- tcSpecPrags poly_id prag_sigs
......
......@@ -71,6 +71,7 @@ import TypeRep
import Class
import Name
import NameEnv
import VarEnv
import HscTypes
import DynFlags
import SrcLoc
......@@ -286,7 +287,7 @@ tcLookupTyVar :: Name -> TcM TcTyVar
tcLookupTyVar name = do
thing <- tcLookup name
case thing of
ATyVar _ ty -> return (tcGetTyVar "tcLookupTyVar" ty)
ATyVar _ tv -> return tv
_ -> pprPanic "tcLookupTyVar" (ppr name)
tcLookupId :: Name -> TcM Id
......@@ -340,18 +341,36 @@ tcExtendKindEnvTvs bndrs thing_inside
= tcExtendKindEnv (map (hsTyVarNameKind . unLoc) bndrs)
(thing_inside bndrs)
-----------------------
-- Scoped type and kind variables
tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r
tcExtendTyVarEnv tvs thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, mkTyVarTy tv) | tv <- tvs] thing_inside
= tcExtendTyVarEnv2 [(tyVarName tv, tv) | tv <- tvs] thing_inside
tcExtendTyVarEnv2 :: [(Name,TcType)] -> TcM r -> TcM r
tcExtendTyVarEnv2 :: [(Name,TcTyVar)] -> TcM r -> TcM r
tcExtendTyVarEnv2 binds thing_inside
= tc_extend_local_env [(name, ATyVar name ty) | (name, ty) <- binds] thing_inside
getScopedTyVarBinds :: TcM [(Name, TcType)]
= tc_extend_local_env [(name, ATyVar name tv) | (name, tv) <- binds] $
do { env <- getLclEnv
; let env' = env { tcl_tidy = add_tidy_tvs (tcl_tidy env) }
; setLclEnv env' thing_inside }
where
add_tidy_tvs env = foldl add env binds
-- We initialise the "tidy-env", used for tidying types before printing,
-- by building a reverse map from the in-scope type variables to the
-- OccName that the programmer originally used for them
add :: TidyEnv -> (Name, TcTyVar) -> TidyEnv
add (env,subst) (name, tyvar)
= case tidyOccName env (nameOccName name) of
(env', occ') -> (env', extendVarEnv subst tyvar tyvar')
where
tyvar' = setTyVarName tyvar name'
name' = tidyNameOcc name occ'
getScopedTyVarBinds :: TcM [(Name, TcTyVar)]
getScopedTyVarBinds
= do { lcl_env <- getLclEnv
; return [(name, ty) | ATyVar name ty <- nameEnvElts (tcl_env lcl_env)] }
; return [(name, tv) | ATyVar name tv <- nameEnvElts (tcl_env lcl_env)] }
\end{code}
......@@ -398,8 +417,8 @@ tcExtendGhciEnv ids thing_inside
| id <- ids]
thing_inside
where
is_top id | isEmptyVarSet (tcTyVarsOfType (idType id)) = TopLevel
| otherwise = NotTopLevel
is_top id | isEmptyVarSet (tyVarsOfType (idType id)) = TopLevel
| otherwise = NotTopLevel
tc_extend_local_env :: [(Name, TcTyThing)] -> TcM a -> TcM a
......@@ -435,8 +454,8 @@ tc_extend_local_env extra_env thing_inside
emptyVarSet
NotTopLevel -> id_tvs
where
id_tvs = tcTyVarsOfType (idType id)
get_tvs (_, ATyVar _ ty) = tcTyVarsOfType ty -- See Note [Global TyVars]
id_tvs = tyVarsOfType (idType id)
get_tvs (_, ATyVar _ tv) = unitVarSet tv -- See Note [Global TyVars]
get_tvs other = pprPanic "get_tvs" (ppr other)
-- Note [Global TyVars]
......
......@@ -992,20 +992,21 @@ find_thing tidy_env ignore_it (ATcId { tct_id = id })
ppr (getSrcLoc id)))]
; return (tidy_env', Just msg) } }
find_thing tidy_env ignore_it (ATyVar tv ty)
= do { (tidy_env1, tidy_ty) <- zonkTidyTcType tidy_env ty
find_thing tidy_env ignore_it (ATyVar name tv)
= do { ty <- zonkTcTyVar tv
; let (tidy_env1, tidy_ty) = tidyOpenType tidy_env ty
; if ignore_it tidy_ty then
return (tidy_env, Nothing)
else do
{ let -- The name tv is scoped, so we don't need to tidy it
msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr tv) <+> eq_stuff
msg = sep [ ptext (sLit "Scoped type variable") <+> quotes (ppr name) <+> eq_stuff
, nest 2 bound_at]
eq_stuff | Just tv' <- tcGetTyVar_maybe tidy_ty
, getOccName tv == getOccName tv' = empty
, getOccName name == getOccName tv' = empty
| otherwise = equals <+> ppr tidy_ty
-- It's ok to use Type.getTyVar_maybe because ty is zonked by now
bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc tv)
bound_at = parens $ ptext (sLit "bound at:") <+> ppr (getSrcLoc name)
; return (tidy_env1, Just msg) } }
......
......@@ -199,7 +199,7 @@ tcExpr (ExprWithTySig expr sig_ty) res_ty
-- Remember to extend the lexical type-variable environment
; (gen_fn, expr')
<- tcGen ExprSigCtxt sig_tc_ty $ \ skol_tvs res_ty ->
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` mkTyVarTys skol_tvs) $
tcExtendTyVarEnv2 (hsExplicitTvs sig_ty `zip` skol_tvs) $
-- See Note [More instantiated than scoped] in TcBinds
tcMonoExprNC expr res_ty
......
......@@ -576,7 +576,7 @@ kcTyVar name -- Could be a tyvar, a tycon, or a datacon
; thing <- tcLookup name
; traceTc "lk2" (ppr name <+> ppr thing)
; case thing of
ATyVar _ ty -> wrap_mono (typeKind ty)
ATyVar _ tv -> wrap_mono (tyVarKind tv)
AThing kind -> wrap_poly kind
AGlobal (ATyCon tc) -> wrap_poly (tyConKind tc)
AGlobal (ADataCon dc) -> kcDataCon dc >>= wrap_poly
......@@ -801,7 +801,7 @@ ds_var_app name arg_tys
| isTvNameSpace (rdrNameSpace (nameRdrName name))
= do { thing <- tcLookup name
; case thing of
ATyVar _ ty -> return (mkAppTys ty arg_tys)
ATyVar _ tv -> return (mkAppTys (mkTyVarTy tv) arg_tys)
_ -> wrongThingErr "type" thing name }
| otherwise
......@@ -924,8 +924,10 @@ Hence using zonked_kinds when forming 'tyvars'.
\begin{code}
tcTyClTyVars :: Name -> [LHsTyVarBndr Name] -- LHS of the type or class decl
-> ([TyVar] -> Kind -> TcM a) -> TcM a
-- tcTyClTyVars T [a,b] calls thing_inside with
-- [k1,k2,a,b] (k2 -> *) where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
-- (tcTyClTyVars T [a,b] thing_inside)
-- where T : forall k1 k2 (a:k1 -> *) (b:k1). k2 -> *
-- calls thing_inside with arguments
-- [k1,k2,a,b] (k2 -> *)
--
-- No need to freshen the k's because they are just skolem
-- constants here, and we are at top level anyway.
......@@ -954,13 +956,17 @@ kindGeneralizeKinds :: [TcKind] -> TcM ([KindVar], [Kind])
kindGeneralizeKinds kinds
= do { -- Quantify over kind variables free in
-- the kinds, and *not* in the environment
; traceTc "kindGeneralizeKinds 1" (ppr kinds)
; zonked_kinds <- mapM zonkTcKind kinds
; gbl_tvs <- tcGetGlobalTyVars -- Already zonked
; let kvs_to_quantify = tyVarsOfTypes zonked_kinds
`minusVarSet` gbl_tvs
; tidy_env <- tcInitTidyEnv
; let kvs_to_quantify = varSetElems (tyVarsOfTypes zonked_kinds
`minusVarSet` gbl_tvs)
; kvs <- ASSERT2 (all isKiVar (varSetElems kvs_to_quantify), ppr kvs_to_quantify)
zonkQuantifiedTyVars kvs_to_quantify
(_, tidy_kvs_to_quantify) = tidyTyVarBndrs tidy_env kvs_to_quantify
; kvs <- ASSERT2 (all isKiVar kvs_to_quantify, ppr kvs_to_quantify)
zonkQuantifiedTyVars tidy_kvs_to_quantify
-- Zonk the kinds again, to pick up either the kind
-- variables we quantify over, or *, depending on whether
......@@ -968,8 +974,8 @@ kindGeneralizeKinds kinds
-- turn depends on PolyKinds)
; final_kinds <- mapM zonkTcKind zonked_kinds
; traceTc "generalizeKind" ( ppr kinds <+> ppr kvs_to_quantify
<+> ppr kvs <+> ppr final_kinds)
; traceTc "kindGeneralizeKinds 2" (vcat [ ppr gbl_tvs, ppr kinds, ppr kvs_to_quantify
, ppr kvs, ppr final_kinds ])
; return (kvs, final_kinds) }
kindGeneralizeKind :: TcKind -> TcM ( [KindVar] -- these were flexi kind vars
......@@ -1097,11 +1103,11 @@ tcHsPatSigType ctxt hs_ty
tcPatSig :: UserTypeCtxt
-> LHsType Name
-> TcSigmaType
-> TcM (TcType, -- The type to use for "inside" the signature
[(Name, TcType)], -- The new bit of type environment, binding
-- the scoped type variables
HsWrapper) -- Coercion due to unification with actual ty
-- Of shape: res_ty ~ sig_ty
-> TcM (TcType, -- The type to use for "inside" the signature
[(Name, TcTyVar)], -- The new bit of type environment, binding
-- the scoped type variables
HsWrapper) -- Coercion due to unification with actual ty
-- Of shape: res_ty ~ sig_ty
tcPatSig ctxt sig res_ty
= do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig
-- sig_tvs are the type variables free in 'sig',
......@@ -1136,30 +1142,32 @@ tcPatSig ctxt sig res_ty
-- Now do a subsumption check of the pattern signature against res_ty
; sig_tvs' <- tcInstSigTyVars sig_tvs
; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty
sig_tv_tys' = mkTyVarTys sig_tvs'
; let sig_ty' = substTyWith sig_tvs (mkTyVarTys sig_tvs') sig_ty
; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty'
-- Check that each is bound to a distinct type variable,
-- and one that is not already in scope
; binds_in_scope <- getScopedTyVarBinds
; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys'
; let tv_binds :: [(Name,TcTyVar)]
tv_binds = map tyVarName sig_tvs `zip` sig_tvs'
; check binds_in_scope tv_binds
-- Phew!
; return (sig_ty', tv_binds, wrap)
} }
where
check _ [] = return ()
check in_scope ((n,ty):rest) = do { check_one in_scope n ty
; check ((n,ty):in_scope) rest }
check_one in_scope n ty
= checkTc (null dups) (dupInScope n (head dups) ty)
check :: [(Name,TcTyVar)] -> [(Name, TcTyVar)] -> TcM ()
check _ [] = return ()
check in_scope ((n,tv):rest) = do { check_one in_scope n tv
; check ((n,tv):in_scope) rest }
check_one :: [(Name,TcTyVar)] -> Name -> TcTyVar -> TcM ()
check_one in_scope n tv
= checkTc (null dups) (dupInScope n (head dups) tv)
-- Must not bind to the same type variable
-- as some other in-scope type variable
where
dups = [n' | (n',ty') <- in_scope, eqType ty' ty]
dups = [n' | (n',tv') <- in_scope, tv' == tv]
\end{code}
......@@ -1394,7 +1402,7 @@ badPatSigTvs sig_ty bad_tvs
, ptext (sLit "To fix this, expand the type synonym")
, ptext (sLit "[Note: I hope to lift this restriction in due course]") ]
dupInScope :: Name -> Name -> Type -> SDoc
dupInScope :: Name -> Name -> TcTyVar -> SDoc
dupInScope n n' _
= hang (ptext (sLit "The scoped type variables") <+> quotes (ppr n) <+> ptext (sLit "and") <+> quotes (ppr n'))
2 (vcat [ptext (sLit "are bound to the same type (variable)"),
......
......@@ -60,7 +60,7 @@ module TcMType (
--------------------------------
-- Zonking
zonkType, zonkKind, zonkTcPredType,
zonkTcTypeCarefully, skolemiseUnboundMetaTyVar,
skolemiseUnboundMetaTyVar,
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar,
zonkQuantifiedTyVar, zonkQuantifiedTyVars,
zonkTcType, zonkTcTypes, zonkTcThetaType,
......@@ -479,10 +479,17 @@ the environment.
tcGetGlobalTyVars :: TcM TcTyVarSet
tcGetGlobalTyVars
= do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv
; gbl_tvs <- readMutVar gtv_var
; gbl_tvs' <- zonkTcTyVarsAndFV gbl_tvs
; gbl_tvs <- readMutVar gtv_var
; tys <- mapM zonk_tv (varSetElems gbl_tvs)
; let gbl_tvs' = tyVarsOfTypes tys
; writeMutVar gtv_var gbl_tvs'
; return gbl_tvs' }
where
zonk_tv tv | isTcTyVar tv = zonkTcTyVar tv
| otherwise = return (mkTyVarTy tv)
-- Hackily, the global tyvars can contain non-TcTyVars
-- These are added (only) in TcHsType.tcTyClTyVars, but it seems
-- painful to make them into TcTyVars there
\end{code}
----------------- Type variables
......@@ -495,29 +502,6 @@ zonkTcTyVarsAndFV :: TcTyVarSet -> TcM TcTyVarSet
zonkTcTyVarsAndFV tyvars = tyVarsOfTypes <$> mapM zonkTcTyVar (varSetElems tyvars)
----------------- Types
zonkTcTypeCarefully :: TcType -> TcM TcType
-- Do not zonk type variables free in the environment
zonkTcTypeCarefully ty = zonkTcType ty -- I think this function is out of date
{-
= do { env_tvs <- tcGetGlobalTyVars
; zonkType (zonk_tv env_tvs) ty }
where
zonk_tv env_tvs tv
| tv `elemVarSet` env_tvs
= return (TyVarTy tv)
| otherwise
= ASSERT( isTcTyVar tv )
case tcTyVarDetails tv of
SkolemTv {} -> return (TyVarTy tv)
RuntimeUnk {} -> return (TyVarTy tv)
FlatSkol ty -> zonkType (zonk_tv env_tvs) ty
MetaTv _ ref -> do { cts <- readMutVar ref
; case cts of
Flexi -> return (TyVarTy tv)
Indirect ty -> zonkType (zonk_tv env_tvs) ty }
-}
zonkTcType :: TcType -> TcM TcType
-- Simply look through all Flexis
zonkTcType ty = zonkType zonkTcTyVar ty
......@@ -583,11 +567,11 @@ defaultKindVarToStar kv
writeMetaTyVar kv liftedTypeKind
; return liftedTypeKind }
zonkQuantifiedTyVars :: TcTyVarSet -> TcM [TcTyVar]
zonkQuantifiedTyVars :: [TcTyVar] -> TcM [TcTyVar]
-- Precondition: a kind variable occurs before a type
-- variable mentioning it in its kind
zonkQuantifiedTyVars tyvars
= do { let (kvs, tvs) = partitionKiTyVars (varSetElems tyvars)
= do { let (kvs, tvs) = partitionKiTyVars tyvars
; poly_kinds <- xoptM Opt_PolyKinds
; if poly_kinds then
mapM zonkQuantifiedTyVar (kvs ++ tvs)
......
......@@ -147,6 +147,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
tcl_th_ctxt = topStage,
tcl_arrow_ctxt = NoArrowCtxt,
tcl_env = emptyNameEnv,
tcl_tidy = emptyTidyEnv,
tcl_tyvars = tvs_var,
tcl_lie = lie_var,
tcl_meta = meta_var,
......@@ -909,30 +910,11 @@ add_warn_at loc msg extra_info
let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
msg extra_info } ;
reportWarning warn }
\end{code}
-----------------------------------
Tidying
We initialise the "tidy-env", used for tidying types before printing,
by building a reverse map from the in-scope type variables to the
OccName that the programmer originally used for them
\begin{code}
tcInitTidyEnv :: TcM TidyEnv
tcInitTidyEnv
= do { lcl_env <- getLclEnv
; let nm_tv_prs = [ (name, tcGetTyVar "tcInitTidyEnv" ty)
| ATyVar name ty <- nameEnvElts (tcl_env lcl_env)
, tcIsTyVarTy ty ]
; return (foldl add emptyTidyEnv nm_tv_prs) }
where
add (env,subst) (name, tyvar)
= case tidyOccName env (nameOccName name) of
(env', occ') -> (env', extendVarEnv subst tyvar tyvar')
where
tyvar' = setTyVarName tyvar name'
name' = tidyNameOcc name occ'
; return (tcl_tidy lcl_env) }
\end{code}
-----------------------------------
......
......@@ -1157,10 +1157,10 @@ reifyThing (ATcId {tct_id = id})
; fix <- reifyFixity (idName id)
; return (TH.VarI (reifyName id) ty2 Nothing fix) }
reifyThing (ATyVar tv ty)
= do { ty1 <- zonkTcType ty
; ty2 <- reifyType ty1
; return (TH.TyVarI (reifyName tv) ty2) }
reifyThing (ATyVar tv tv1)
= do { ty1 <- zonkTcTyVar tv1
; ty2 <- reifyType ty1
; return (TH.TyVarI (reifyName tv) ty2) }
reifyThing (AThing {}) = panic "reifyThing AThing"
reifyThing ANothing = panic "reifyThing ANothing"
......
......@@ -88,7 +88,7 @@ module TcType (
tidyType, tidyTypes,
tidyOpenType, tidyOpenTypes,
tidyOpenKind,
tidyTyVarBndr, tidyFreeTyVars,
tidyTyVarBndr, tidyTyVarBndrs, tidyFreeTyVars,
tidyOpenTyVar, tidyOpenTyVars,
tidyTyVarOcc,
tidyTopType,
......@@ -451,6 +451,9 @@ Tidying is here becuase it has a special case for FlatSkol
-- an interface file.
--
-- It doesn't change the uniques at all, just the print names.
tidyTyVarBndrs :: TidyEnv -> [TyVar] -> (TidyEnv, [TyVar])
tidyTyVarBndrs env tvs = mapAccumL tidyTyVarBndr env tvs
tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar)
tidyTyVarBndr tidy_env@(occ_env, subst) tyvar
= case tidyOccName occ_env occ1 of
......
Markdown is supported
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