-instant_help ty lookup_tv deflt_tv choose_tycon
- if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
- = go ty
- where
- go (TyVarTy tv) = case (lookup_tv tv) of
- Nothing -> deflt_tv tv
- Just ty -> ty
- go ty@(TyConTy tycon usage) = choose_tycon ty tycon usage
- go (SynTy tycon tys ty) = SynTy tycon (map go tys) (go ty)
- go (FunTy arg res usage) = FunTy (go arg) (go res) usage
- go (AppTy fun arg) = AppTy (go fun) (go arg)
- go (DictTy clas ty usage) = DictTy clas (go ty) usage
- go (ForAllUsageTy uvar bds ty) = if_usage $
- ForAllUsageTy uvar bds (go ty)
- go (ForAllTy tv ty) = if_forall $
- (if (bound_forall_tv_BAD && maybeToBool (lookup_tv tv)) then
- trace "instantiateTy: unexpected forall hit"
- else
- \x->x) ForAllTy (deflt_forall_tv tv) (go ty)
-
-instantiateTy [] ty = ty
-
-instantiateTy tenv ty
- = instant_help ty lookup_tv deflt_tv choose_tycon
- if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
- where
- lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
- [] -> Nothing
- [ty] -> Just ty
- _ -> panic "instantiateTy:lookup_tv"
-
- deflt_tv tv = TyVarTy tv
- choose_tycon ty _ _ = ty
- if_usage ty = ty
- if_forall ty = ty
- bound_forall_tv_BAD = True
- deflt_forall_tv tv = tv
-
-instantiateTauTy tenv ty
- = instant_help ty lookup_tv deflt_tv choose_tycon
- if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
- where
- lookup_tv tv = case [ty | (tv',ty) <- tenv, tv == tv'] of
- [] -> Nothing
- [ty] -> Just ty
- _ -> panic "instantiateTauTy:lookup_tv"
-
- deflt_tv tv = panic "instantiateTauTy"
- choose_tycon _ tycon usage = TyConTy tycon usage
- if_usage ty = panic "instantiateTauTy:ForAllUsageTy"
- if_forall ty = panic "instantiateTauTy:ForAllTy"
- bound_forall_tv_BAD = panic "instantiateTauTy:bound_forall_tv"
- deflt_forall_tv tv = panic "instantiateTauTy:deflt_forall_tv"
-
-instantiateThetaTy tenv theta
- = [(clas,instantiateTauTy tenv ty) | (clas,ty) <- theta]
-
--- applyTypeEnv applies a type environment to a type.
--- It can handle shadowing; for example:
--- f = /\ t1 t2 -> \ d ->
--- letrec f' = /\ t1 -> \x -> ...(f' t1 x')...
--- in f' t1
--- Here, when we clone t1 to t1', say, we'll come across shadowing
--- when applying the clone environment to the type of f'.
---
--- As a sanity check, we should also check that name capture
--- doesn't occur, but that means keeping track of the free variables of the
--- range of the TyVarEnv, which I don't do just yet.
---
--- We don't use instant_help because we need to carry in the environment
-
-applyTypeEnvToTy tenv ty
- = go tenv ty
- where
- go tenv ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of
- Nothing -> ty
- Just ty -> ty
- go tenv ty@(TyConTy tycon usage) = ty
- go tenv (SynTy tycon tys ty) = SynTy tycon (map (go tenv) tys) (go tenv ty)
- go tenv (FunTy arg res usage) = FunTy (go tenv arg) (go tenv res) usage
- go tenv (AppTy fun arg) = AppTy (go tenv fun) (go tenv arg)
- go tenv (DictTy clas ty usage) = DictTy clas (go tenv ty) usage
- go tenv (ForAllUsageTy uvar bds ty) = ForAllUsageTy uvar bds (go tenv ty)
- go tenv (ForAllTy tv ty) = ForAllTy tv (go tenv' ty)
- where
- tenv' = case lookupTyVarEnv tenv tv of
- Nothing -> tenv
- Just _ -> delFromTyVarEnv tenv tv
-\end{code}