-Given a type and value substitution, specUDs creates a specialised copy of
-the given UDs
-
-\begin{code}
-specUDs :: TyVarSubst -> IdSubst -> ProtoUsageDetails -> SpecM UsageDetails
-specUDs tv_env dict_env (dbs, calls)
- = getUniqSupplySM `thenSM` \ us ->
- let
- ((us', dict_env'), dbs') = mapAccumL specDB (us, dict_env) dbs
- in
- setUniqSupplySM us' `thenSM_`
- returnSM (MkUD { dict_binds = listToBag dbs',
- calls = foldr (unionCalls . singleCall . inst_call dict_env')
- emptyFM calls
- })
- where
- inst_call dict_env (id, tys, (dicts,fvs)) = (id, map (inst_maybe_ty fvs) tys,
- map (substExpr tv_env dict_env fvs) dicts)
-
- inst_maybe_ty fvs Nothing = Nothing
- inst_maybe_ty fvs (Just ty) = Just (fullSubstTy tv_env fvs ty)
-
- specDB (us, dict_env) (NonRec bndr rhs, fvs)
- = ((us', dict_env'), mkDB (NonRec bndr' (substExpr tv_env dict_env fvs rhs)))
- where
- (dict_env', _, us', bndr') = substId clone_fn tv_env dict_env fvs us bndr
- -- Fudge the in_scope set a bit by using the free vars of
- -- the binding, and ignoring the one that comes back
-
- specDB (us, dict_env) (Rec prs, fvs)
- = ((us', dict_env'), mkDB (Rec (bndrs' `zip` rhss')))
- where
- (dict_env', _, us', bndrs') = substIds clone_fn tv_env dict_env fvs us (map fst prs)
- rhss' = [substExpr tv_env dict_env' fvs rhs | (_, rhs) <- prs]
-
- clone_fn _ us id = case splitUniqSupply us of
- (us1, us2) -> Just (us1, setVarUnique id (uniqFromSupply us2))
-\end{code}