- go (TyVarTy tv) = case [ty | (tv',ty) <- tenv, tv==tv'] of
- (ty:_) -> ty
- [] -> panic "instantiateTauTy"
- go (TyConTy tycon usage) = TyConTy 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
-
-instantiateUsage
- :: Ord3 u => [(u, GenType t u')] -> GenType t u -> GenType t u'
-instantiateUsage = error "instantiateUsage: not implemented"
-\end{code}
-
-\begin{code}
-type TypeEnv = TyVarEnv Type
+ 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 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"
+
+
+-- 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