- extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
- ) `thenDs` (\ (binds, subst_env) ->
- returnDs (binds, subst_item : subst_env)
- ))
-
-dsInstBinds tyvars ((inst, expr) : bs)
- | null abs_tyvars
- = dsExpr expr `thenDs` \ core_expr ->
- ds_dict_cc core_expr `thenDs` \ dict_expr ->
- dsInstBinds tyvars bs `thenDs` \ (core_rest, subst_env) ->
- returnDs ((inst, dict_expr) : core_rest, subst_env)
-
- | otherwise
- = -- Obscure case.
- -- The inst mentions the type vars wrt which we are abstracting,
- -- so we have to invent a new polymorphic version, and substitute
- -- appropriately.
- -- This can occur in, for example:
- -- leftPoll :: [FeedBack a] -> FeedBack a
- -- leftPoll xs = take poll xs
- -- Here there is an instance of take at the type of elts of xs,
- -- as well as the type of poll.
-
- dsExpr expr `thenDs` \ core_expr ->
- ds_dict_cc core_expr `thenDs` \ dict_expr ->
- newSysLocalDs poly_inst_ty `thenDs` \ poly_inst_id ->
- let
- subst_item = (inst, mkTyApp (Var poly_inst_id) abs_tys)
- in
- extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
- ) `thenDs` \ (core_rest, subst_env) ->
- returnDs ((poly_inst_id, mkTyLam abs_tyvars dict_expr) : core_rest,
- subst_item : subst_env)
- where
- inst_ty = idType inst
- abs_tyvars = extractTyVarsFromTy inst_ty `intersectLists` tyvars
- abs_tys = map mkTyVarTy abs_tyvars
- (_, poly_inst_ty) = quantifyTy abs_tyvars inst_ty
-
- ------------------------
- -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
- -- appropriate. Uses "inst"'s type.
-
- ds_dict_cc expr
- = -- if profiling, wrap the dict in "_scc_ DICT <dict>":
- let
- doing_profiling = opt_SccProfilingOn
- compiling_prelude = opt_CompilingPrelude
- in
- if not doing_profiling
- || not (isDictTy inst_ty) then -- that's easy: do nothing
- returnDs expr
- else if compiling_prelude then
- returnDs (SCC prel_dicts_cc expr)
- else
- getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) ->
- -- ToDo: do -dicts-all flag (mark dict things
- -- with individual CCs)
- let
- dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-}
- in
- returnDs (SCC dict_cc expr)
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[dsBind]{Desugaring a @Bind@}
-%* *
-%************************************************************************
-
-Like @dsBinds@, @dsBind@ returns a @[CoreBinding]@, but it may be that
-some of the binders are of unboxed type.
-
-For an explanation of the first three args, see @dsMonoBinds@.
-
-\begin{code}
-dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these
- -> (Id -> Id) -- Binder substitution
- -> [(Id,CoreExpr)] -- Inst bindings already dealt with
- -> TypecheckedBind
- -> DsM [CoreBinding]
-
-dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind
- = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs]
-
-dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds)
- = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
- returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] )
-
-dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds)
- = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs ->
- returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] )