\begin{code}
module Rules (
RuleBase, emptyRuleBase,
- extendRuleBase, extendRuleBaseList,
- ruleBaseIds, getLocalRules,
- pprRuleBase, ruleCheckProgram,
+ extendRuleBaseList,
+ ruleBaseIds, pprRuleBase, ruleCheckProgram,
lookupRule, addRule, addIdSpecialisations
) where
substEnv, setSubstEnv, emptySubst, isInScope, emptyInScopeSet,
bindSubstList, unBindSubstList, substInScope, uniqAway
)
-import Id ( Id, idIsFrom, idUnfolding, idSpecialisation, setIdSpecialisation )
+import Id ( Id, idUnfolding, idSpecialisation, setIdSpecialisation )
import Var ( isId )
import VarSet
import VarEnv
import TcType ( mkTyVarTy )
import qualified TcType ( match )
import BasicTypes ( Activation, CompilerPhase, isActive )
-import Module ( Module )
import Outputable
import FastString
import Maybe ( isJust, isNothing, fromMaybe )
-import Util ( sortLt )
+import Util ( sortLe )
import Bag
-import List ( isPrefixOf, partition )
+import List ( isPrefixOf )
\end{code}
match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
= match e1 e2 tpl_vars case_kont subst
where
- case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLt lt_alt alts2))
+ case_kont subst = bind [x1] [x2] (match_alts alts1 (sortLe le_alt alts2))
tpl_vars kont subst
match (Type ty1) (Type ty2) tpl_vars kont subst
subst
match_alts alts1 alts2 tpl_vars kont subst = match_fail
-lt_alt (con1, _, _) (con2, _, _) = con1 < con2
+le_alt (con1, _, _) (con2, _, _) = con1 <= con2
----------------------------------------
bind :: [CoreBndr] -- Template binders
-- in which case it may have rules in its belly already. Seems
-- dreadfully hackoid.
-getLocalRules :: Module -> RuleBase -> (IdSet, -- Ids with local rules
- RuleBase) -- Non-local rules
--- Get the rules for locally-defined Ids out of the RuleBase
--- If we miss any rules for Ids defined here, then we end up
--- giving the local decl a new Unique (because the in-scope-set is (hackily) the
--- same as the non-local-rule-id set, so the Id looks as if it's in scope
--- and hence should be cloned), and now the binding for the class method
--- doesn't have the same Unique as the one in the Class and the tc-env
--- Example: class Foo a where
--- op :: a -> a
--- {-# RULES "op" op x = x #-}
---
--- NB we can't use isLocalId, because isLocalId isn't true of class methods.
-getLocalRules this_mod (RuleBase ids)
- = (mkVarSet local_ids, RuleBase (mkVarSet imp_ids))
- where
- (local_ids, imp_ids) = partition (idIsFrom this_mod) (varSetElems ids)
-
pprRuleBase :: RuleBase -> SDoc
pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ]
\end{code}