- listDs [ mkSatTyApp global tyvar_tys `thenDs` \ app ->
- returnDs (local, app)
- | (local,global) <- full_local_global_prs
- ] `thenDs` \ env ->
-
--- pprTrace "AbsBinds1:" (ppr PprDebug env) $
-
- extendEnvDs env (
-
- dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
- extendEnvDs inst_env (
-
- dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds
- ))
- where
- -- "private_binders" is the list of binders in val_binds
- -- which don't appear in the local_global_prs list
- -- These only really show up in stuff produced from compiling
- -- class and instance declarations.
- -- We need to add suitable polymorphic versions of them to the
- -- local_global_prs.
- private_binders = binders `minusList` [local | (local,_) <- local_global_prs]
- binders = collectTypedBinders val_binds
- mk_poly_private_binder id = newSysLocalDs (mkForAllTys tyvars (idType id))
-
- tyvar_tys = mkTyVarTys tyvars
-\end{code}
-
-
-%==============================================
-\subsubsection{AbsBind case: overloading}
-%==============================================
-
-If there is overloading we go for the general case.
-
-We want the global identifiers to be abstracted wrt all types and
-dictionaries; and the local identifiers wrt the non-overloaded types.
-That is, we try to avoid global scoping of type abstraction. Example
-
- f :: Eq a => a -> [(a,b)] -> b
- f = ...f...
-
-Here, f is fully polymorphic in b. So we generate
-
- f ab d = let ...dict defns...
- in
- letrec f' b = ...(f' b)...
- in f' b
-
-*Notice* that we don't clone type variables, and *do* make use of
-shadowing. It is possible to do cloning, but it makes the code quite
-a bit more complicated, and the simplifier will clone it all anyway.
-
-Why bother with this gloss? Because it makes it more likely that
-the defn of f' can get floated out, notably if f gets specialised
-to a particular type for a.
-
-\begin{code}
-dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds)
- = -- If there is any non-overloaded polymorphism, make new locals with
- -- appropriate polymorphism
- (if null non_overloaded_tyvars
- then
- -- No non-overloaded polymorphism, so stay with current envt
- returnDs (id, [], [])
- else
- -- Some local, non-overloaded polymorphism
- cloneTyVarsDs non_overloaded_tyvars `thenDs` \ local_tyvars ->
-
- mapDs mk_binder binders `thenDs` \ new_binders ->
- let
- old_new_pairs = binders `zip` new_binders
- in
-
- listDs [ mkSatTyApp new non_ov_tyvar_tys `thenDs` \ app ->
- returnDs (old, app)
- | (old,new) <- old_new_pairs
- ] `thenDs` \ extra_env ->
- let
- local_binds = [NonRec old app | (old,app) <- extra_env, old `is_elem` locals]
- is_elem = isIn "dsBinds"
- in
- returnDs (lookupId old_new_pairs, extra_env, local_binds)
- )
- `thenDs` \ (binder_subst_fn, local_env, local_binds) ->
-
--- pprTrace "AbsBinds:all:" (ppAbove (ppr PprDebug local_binds) (ppr PprDebug local_env)) $
-
- extendEnvDs local_env (
-
- dsInstBinds non_overloaded_tyvars dict_binds `thenDs` \ (inst_bind_pairs, inst_env) ->
-
- extendEnvDs inst_env (
-
- dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds
- )) `thenDs` \ core_binds ->
-
- let
- tuple_rhs = mkCoLetsAny core_binds (
- mkCoLetsAny local_binds (
- mkTupleExpr locals ))
- in
- mkTupleBind all_tyvars dicts local_global_prs tuple_rhs `thenDs` \ core_bind_prs ->
-
- returnDs [ NonRec binder rhs | (binder,rhs) <- core_bind_prs ]
- where
- locals = [local | (local,global) <- local_global_prs]
- non_ov_tyvar_tys = mkTyVarTys non_overloaded_tyvars
-
- overloaded_tyvars = tyVarsOfTypes (map idType dicts)
- non_overloaded_tyvars = all_tyvars `minusList` (tyVarSetToList{-????-} overloaded_tyvars)
-
- binders = collectTypedBinders val_binds
- mk_binder id = newSysLocalDs (mkForAllTys non_overloaded_tyvars (idType id))
-\end{code}
-
-@mkSatTyApp id tys@ constructs an expression whose value is (id tys).
-However, sometimes id takes more type args than are in tys, and the
-specialiser hates that, so we have to eta expand, to
-@(/\ a b -> id tys a b)@.
-
-\begin{code}
-mkSatTyApp :: Id -- Id to apply to the types
- -> [Type] -- Types to apply it to
- -> DsM CoreExpr
-
-mkSatTyApp id [] = returnDs (Var id)
-
-mkSatTyApp id tys
- | null tvs
- = returnDs ty_app -- Common case
- | otherwise
- = newTyVarsDs (drop (length tys) tvs) `thenDs` \ tyvars ->
- returnDs (mkTyLam tyvars (mkTyApp ty_app (mkTyVarTys tyvars)))
- where
- (tvs, theta, tau_ty) = splitSigmaTy (idType id)
- ty_app = mkTyApp (Var id) tys
-\end{code}
-
-There are several places where we encounter ``inst binds,''
-@(Id, TypecheckedHsExpr)@ pairs. Many of these are ``trivial'' binds
-(a var to a var or literal), which we want to substitute away; so we
-return both some desugared bindings {\em and} a substitution
-environment for the subbed-away ones.
-
-These dictionary bindings are non-recursive, and ordered, so that
-later ones may mention earlier ones, but not vice versa.
-
-\begin{code}
-dsInstBinds :: [TyVar] -- Abstract wrt these
- -> [(Id, TypecheckedHsExpr)] -- From AbsBinds
- -> DsM ([(Id,CoreExpr)], -- Non-trivial bindings
- [(Id,CoreExpr)]) -- Trivial ones to be substituted away
-
-do_nothing = ([], []) -- out here to avoid dsInstBinds CAF (sigh)
-prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
-
-dsInstBinds tyvars [] = returnDs do_nothing
-
-dsInstBinds tyvars ((inst, expr@(HsVar _)) : bs)
- = dsExpr expr `thenDs` \ rhs ->
- let -- Need to apply dsExpr to the variable in case it
- -- has a substitution in the current environment
- subst_item = (inst, rhs)