+-- addExportFlags
+-- Set the no-discard flag if either
+-- a) the Id is exported
+-- b) it's mentioned in the RHS of an orphan rule
+-- c) it's in the keep-alive set
+--
+-- It means that the binding won't be discarded EVEN if the binding
+-- ends up being trivial (v = w) -- the simplifier would usually just
+-- substitute w for v throughout, but we don't apply the substitution to
+-- the rules (maybe we should?), so this substitution would make the rule
+-- bogus.
+
+-- You might wonder why exported Ids aren't already marked as such;
+-- it's just because the type checker is rather busy already and
+-- I didn't want to pass in yet another mapping.
+
+addExportFlags ghci_mode exports keep_alive prs rules
+ = [(add_export bndr, rhs) | (bndr,rhs) <- prs]
+ where
+ add_export bndr
+ | dont_discard bndr = setIdExported bndr
+ | otherwise = bndr
+
+ orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule
+ | rule <- rules,
+ not (isLocalRule rule) ]
+ -- A non-local rule keeps alive the free vars of its right-hand side.
+ -- (A "non-local" is one whose head function is not locally defined.)
+ -- Local rules are (later, after gentle simplification)
+ -- attached to the Id, and that keeps the rhs free vars alive.
+
+ dont_discard bndr = is_exported name
+ || name `elemNameSet` keep_alive
+ || bndr `elemVarSet` orph_rhs_fvs
+ where
+ name = idName bndr
+
+ -- In interactive mode, we don't want to discard any top-level
+ -- entities at all (eg. do not inline them away during
+ -- simplification), and retain them all in the TypeEnv so they are
+ -- available from the command line.
+ --
+ -- isExternalName separates the user-defined top-level names from those
+ -- introduced by the type checker.
+ is_exported :: Name -> Bool
+ is_exported | ghci_mode == Interactive = isExternalName
+ | otherwise = (`elemNameSet` exports)
+
+ppr_ds_rules [] = empty
+ppr_ds_rules rules
+ = text "" $$ text "-------------- DESUGARED RULES -----------------" $$
+ pprRules rules
+\end{code}
+
+
+
+%************************************************************************
+%* *
+%* Desugaring transformation rules
+%* *
+%************************************************************************
+
+\begin{code}
+dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM (Maybe CoreRule)
+dsRule mod in_scope (L loc (HsRule name act vars lhs rhs))
+ = putSrcSpanDs loc $
+ do { let bndrs = [var | RuleBndr (L _ var) <- vars]
+ ; lhs' <- dsLExpr lhs
+ ; rhs' <- dsLExpr rhs
+
+ ; case decomposeRuleLhs bndrs lhs' of {
+ Nothing -> do { dsWarn msg; return Nothing } ;
+ Just (bndrs', fn_id, args) -> do
+
+ -- Substitute the dict bindings eagerly,
+ -- and take the body apart into a (f args) form
+ { let local_rule = nameIsLocalOrFrom mod fn_name
+ -- NB we can't use isLocalId in the orphan test,
+ -- because isLocalId isn't true of class methods
+ fn_name = idName fn_id
+ lhs_names = fn_name : nameSetToList (exprsFreeNames args)
+ -- No need to delete bndrs, because
+ -- exprsFreeNames finds only External names
+ orph = case filter (nameIsLocalOrFrom mod) lhs_names of
+ (n:ns) -> Just (nameOccName n)
+ [] -> Nothing