import PprCore ( pprRules )
import Type ( Type )
import TcType ( tcSplitTyConApp_maybe )
+import Coercion
import CoreTidy ( tidyRules )
import Id
import IdInfo ( SpecInfo( SpecInfo ) )
-import Var ( Var )
import VarEnv
import VarSet
import Name ( Name, NamedThing(..) )
import Data.List
\end{code}
-
Note [Overall plumbing for rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
* After the desugarer:
roughTopName :: CoreExpr -> Maybe Name
roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of
- Just (tc,_) -> Just (getName tc)
- Nothing -> Nothing
+ Just (tc,_) -> Just (getName tc)
+ Nothing -> Nothing
+roughTopName (Coercion _) = Nothing
roughTopName (App f _) = roughTopName f
-roughTopName (Var f) | isGlobalId f = Just (idName f)
- | otherwise = Nothing
+roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName]
+ , isDataConWorkId f || idArity f > 0
+ = Just (idName f)
roughTopName _ = Nothing
ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
ruleCantMatch _ _ = False
\end{code}
+Note [Care with roughTopName]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this
+ module M where { x = a:b }
+ module N where { ...f x...
+ RULE f (p:q) = ... }
+You'd expect the rule to match, because the matcher can
+look through the unfolding of 'x'. So we must avoid roughTopName
+returning 'M.x' for the call (f x), or else it'll say "can't match"
+and we won't even try!!
+
+However, suppose we have
+ RULE g (M.h x) = ...
+ foo = ...(g (M.k v))....
+where k is a *function* exported by M. We never really match
+functions (lambdas) except by name, so in this case it seems like
+a good idea to treat 'M.k' as a roughTopName of the call.
+
+
\begin{code}
pprRulesForUser :: [CoreRule] -> SDoc
-- (a) tidy the rules
-- See Note [Extra args in rule matching]
-- See comments on matchRule
lookupRule is_active id_unf in_scope fn args rules
- = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
+ = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $
case go [] rules of
[] -> Nothing
(m:ms) -> Just (findBest (fn,args) m ms)
-- succeed in matching what looks like the template variable 'a' against 3.
-- The Var case follows closely what happens in Unify.match
-match renv subst (Var v1) e2
- | Just subst <- match_var renv subst v1 e2
- = Just subst
-
+match renv subst (Var v1) e2 = match_var renv subst v1 e2
match renv subst (Note _ e1) e2 = match renv subst e1 e2
match renv subst e1 (Note _ e2) = match renv subst e1 e2
-- Ignore notes in both template and thing to be matched
match renv subst (Type ty1) (Type ty2)
= match_ty renv subst ty1 ty2
+match renv subst (Coercion co1) (Coercion co2)
+ = match_co renv subst co1 co2
match renv subst (Cast e1 co1) (Cast e2 co2)
- = do { subst1 <- match_ty renv subst co1 co2
+ = do { subst1 <- match_co renv subst co1 co2
; match renv subst1 e1 e2 }
-- Everything else fails
match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $
Nothing
+-------------
+match_co :: RuleEnv
+ -> RuleSubst
+ -> Coercion
+ -> Coercion
+ -> Maybe RuleSubst
+match_co renv subst (CoVarCo cv) co
+ = match_var renv subst cv (Coercion co)
+match_co _ _ co1 _
+ = pprTrace "match_co baling out" (ppr co1) Nothing
+
+-------------
rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv
rnMatchBndr2 renv subst x1 x2
= renv { rv_lcl = rnBndr2 rn_env x1 x2
ruleCheck _ (Var _) = emptyBag
ruleCheck _ (Lit _) = emptyBag
ruleCheck _ (Type _) = emptyBag
+ruleCheck _ (Coercion _) = emptyBag
ruleCheck env (App f a) = ruleCheckApp env (App f a) []
ruleCheck env (Note _ e) = ruleCheck env e
ruleCheck env (Cast e _) = ruleCheck env e