- `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
-
-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)
- in
- extendEnvDs [subst_item] (
- dsInstBinds tyvars bs
- ) `thenDs` \ (binds, subst_env) ->
- returnDs (binds, subst_item : subst_env)
-
-dsInstBinds tyvars ((inst, expr@(HsLit _)) : bs)
- = dsExpr expr `thenDs` \ core_lit ->
- let
- subst_item = (inst, core_lit)
- in
- 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 = tyVarSetToList{-???sigh-} (tyVarsOfType inst_ty) `intersectLists` tyvars
- abs_tys = mkTyVarTys abs_tyvars
- poly_inst_ty = mkForAllTys abs_tyvars inst_ty
-
- ------------------------
- -- Wrap a desugared expression in `_scc_ "DICT" <expr>' if
- -- appropriate. Uses "inst"'s type.
-
- -- if profiling, wrap the dict in "_scc_ DICT <dict>":
- ds_dict_cc expr
- | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs)
- -- the latter is so that -unprof-auto-scc-all adds dict sccs
- || not (isDictTy inst_ty)
- = returnDs expr -- that's easy: do nothing
-
- | opt_CompilingGhcInternals
- = returnDs (SCC prel_dicts_cc expr)
-
- | otherwise
- = getModuleAndGroupDs `thenDs` \ (mod, grp) ->
-
- -- ToDo: do -dicts-all flag (mark dict things with individual CCs)
-
- returnDs (SCC (mkAllDictsCC mod grp False) 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)]
projects / ghc-hetmet.git / commitdiff