+%************************************************************************
+%* *
+%* Desugaring transformation rules
+%* *
+%************************************************************************
+
+\begin{code}
+dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
+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 (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
+
+ subst = mkSubst all_vars subst_env
+ body'' = substExpr subst body'
+ in
+
+ -- Now unpack the resulting body
+ let
+ pair = case collectArgs body'' of
+ (Var fn, args) -> (fn, args)
+ other -> pprPanic "dsRule" (ppr lhs)
+ in
+ returnDs pair
+
+ds_dict_binds EmptyMonoBinds = returnDs []
+ds_dict_binds (AndMonoBinds b1 b2) = ds_dict_binds b1 `thenDs` \ env1 ->
+ ds_dict_binds b2 `thenDs` \ env2 ->
+ returnDs (env1 ++ env2)
+ds_dict_binds (VarMonoBind id rhs) = dsExpr rhs `thenDs` \ rhs' ->
+ returnDs [(id,rhs')]