-dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
-\end{code}
-
-All ``real'' bindings are expressed in terms of the
-@AbsBinds@ construct, which is a massively-complicated ``shorthand'',
-and its desugaring is the subject of section~9.1 in the static
-semantics paper.
-
-(ToDo) For:
-\begin{verbatim}
-AbsBinds [a1, ... ,aj] -- type variables
- [d1, ... ,dk] -- dict variables
- [(l1,g1), ..., (lm,gm)] -- overloaded equivs [Id pairs] (later...)
- [db1=..., ..., dbn=...] -- dict binds
- [vb1=..., ..., vbm=...] -- val binds; note: vb_i = l_i
-\end{verbatim}
-we want to make, in the general case (non-Fozzie translation):
-\begin{verbatim}
- -- tupler-upper:
- tup a1...aj d1...dk =
- let <dict-binds> in
- let(rec) <val-binds> in (vb1,...,vbm) -- NB: == ... in (l1,...,lm)
-
- -- a bunch of selectors:
- g1 a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> x1
- ...
- gm a1...aj d1...dk = case (_tup a1...aj d1...dk) of (x1,x2,...,xm) -> xm
-\end{verbatim}
-But there are lots of special cases.
-
-
-%==============================================
-\subsubsection{Structure cases}
-%==============================================
-
-\begin{code}
-dsBinds (BindWith _ _) = panic "dsBinds:BindWith"
-dsBinds EmptyBinds = returnDs []
-dsBinds (SingleBind bind) = dsBind [] [] id [] bind
-
-dsBinds (ThenBinds binds_1 binds_2)
- = andDs (++) (dsBinds binds_1) (dsBinds binds_2)
-\end{code}
-
-
-%==============================================
-\subsubsection{AbsBind case: no overloading}
-%==============================================
-
-Special case: no overloading.
-\begin{verbatim}
- x1 = e1
- x2 = e2
-\end{verbatim}
-We abstract each wrt the type variables, giving
-\begin{verbatim}
- x1' = /\tyvars -> e1[x1' tyvars/x1, x2' tyvars/x2]
- x2' = /\tyvars -> e2[x1' tyvars/x1, x2' tyvars/x2]
-\end{verbatim}
-There are some complications.
-
-(i) The @val_binds@ might mention variable not in @local_global_prs@.
-In this case we need to make up new polymorphic versions of them.
-
-(ii) Exactly the same applies to any @inst_binds@ which may be
-present. However, here we expect that mostly they will be simple constant
-definitions, which don't mention the type variables at all, so making them
-polymorphic is really overkill. @dsInstBinds@ deals with this case.
-
-\begin{code}
-dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds)
- = mapDs mk_poly_private_binder private_binders
- `thenDs` \ poly_private_binders ->
- let
- full_local_global_prs = (private_binders `zip` poly_private_binders)
- ++ local_global_prs
- in
- 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 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 (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 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 (mk_result_bind 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))
-
- is_rec_bind = case val_binds of
- RecBind _ -> True
- NonRecBind _ -> False
-
- -- Recursion can still be needed if there are type signatures
- mk_result_bind prs | is_rec_bind = [Rec prs]
- | otherwise = [NonRec binder rhs | (binder,rhs) <- prs]
-\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