-\begin{code}
-specUDs :: [(TyVar,Type)] -> [(DictVar,DictVar)] -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env_list dict_env_list (dbs, calls)
- = specDBs dict_env_list dbs `thenSM` \ (dict_env_list', dbs') ->
- let
- dict_env = mkIdEnv dict_env_list'
- in
- returnSM (MkUD { dict_binds = dbs',
- calls = listToCallDetails (map (inst_call dict_env) calls)
- })
- where
- bound_tyvars = mkTyVarSet (map fst tv_env_list)
- tv_env = mkTyVarEnv tv_env_list -- Doesn't change
-
- inst_call dict_env (id, tys, dicts) = (id, map inst_maybe_ty tys,
- map (lookupId dict_env) dicts)
-
- inst_maybe_ty Nothing = Nothing
- inst_maybe_ty (Just ty) = Just (instantiateTy tv_env ty)
-
- specDBs dict_env []
- = returnSM (dict_env, emptyBag)
- specDBs dict_env ((dict, rhs, ftvs, fvs) : dbs)
- = newIdSM dict (instantiateTy tv_env (idType dict)) `thenSM` \ dict' ->
- let
- rhs' = foldl App (foldr Lam rhs (t_bndrs ++ d_bndrs)) (t_args ++ d_args)
- (t_bndrs, t_args) = unzip [(TyBinder tv, TyArg ty) | (tv,ty) <- tv_env_list,
- tv `elementOfTyVarSet` ftvs]
- (d_bndrs, d_args) = unzip [(ValBinder d, VarArg d') | (d,d') <- dict_env,
- d `elementOfIdSet` fvs]
- dict_env' = (dict,dict') : dict_env
- ftvs' = tyVarsOfTypes [ty | TyArg ty <- t_args] `unionTyVarSets`
- (ftvs `minusTyVarSet` bound_tyvars)
- fvs' = mkIdSet [d | VarArg d <- d_args] `unionIdSets`
- (fvs `minusIdSet` mkIdSet [d | ValBinder d <- d_bndrs])
- in
- specDBs dict_env' dbs `thenSM` \ (dict_env'', dbs') ->
- returnSM ( dict_env'', (dict', rhs', ftvs', fvs') `consBag` dbs' )