+ auto_scc | opt_SccProfilingOn = TopLevel
+ | otherwise = NoSccs
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+ = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+ vcat (map pprProtoCoreRule rules)
+\end{code}
+
+
+%************************************************************************
+%* *
+%* Desugaring transformation rules
+%* *
+%************************************************************************
+
+\begin{code}
+dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule
+dsRule in_scope (IfaceRuleOut fn rule)
+ = returnDs (ProtoCoreRule False {- non-local -} fn rule)
+
+dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc)
+ = putSrcLocDs loc $
+ ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
+ dsExpr rhs `thenDs` \ core_rhs ->
+ returnDs (ProtoCoreRule True {- local -} fn
+ (Rule name tpl_vars args core_rhs))
+ where
+ tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
+ all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
+
+ds_lhs all_vars lhs
+ = let
+ (dict_binds, body) = case lhs of
+ (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body)
+ other -> (EmptyMonoBinds, lhs)
+ in
+ ds_dict_binds dict_binds `thenDs` \ dict_binds' ->
+ dsExpr body `thenDs` \ body' ->
+
+ -- Substitute the dict bindings eagerly,
+ -- and take the body apart into a (f args) form
+ let
+ subst_env = mkSubstEnv [id | (id,rhs) <- dict_binds']
+ [ContEx subst_env rhs | (id,rhs) <- dict_binds']
+ -- Note recursion here... substitution won't terminate
+ -- if there is genuine recursion... which there isn't