\begin{code}
lookupRule :: (Activation -> Bool) -> InScopeSet
-> RuleBase -- Imported rules
- -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr)
+ -> Id -> [CoreExpr] -> Maybe (CoreRule, CoreExpr)
lookupRule is_active in_scope rule_base fn args
= matchRules is_active in_scope fn args rules
where
matchRules :: (Activation -> Bool) -> InScopeSet
-> Id -> [CoreExpr]
- -> [CoreRule] -> Maybe (RuleName, CoreExpr)
+ -> [CoreRule] -> Maybe (CoreRule, CoreExpr)
-- See comments on matchRule
matchRules is_active in_scope fn args rules
- = case go [] rules of
+ = -- pprTrace "matchRules" (ppr fn <+> ppr rules) $
+ case go [] rules of
[] -> Nothing
- (m:ms) -> Just (case findBest (fn,args) m ms of
- (rule, ans) -> (ru_name rule, ans))
+ (m:ms) -> Just (findBest (fn,args) m ms)
where
rough_args = map roughTopName args
go ms [] = ms
go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of
Just e -> go ((r,e):ms) rs
- Nothing -> go ms rs
+ Nothing -> -- pprTrace "match failed" (ppr r $$ ppr args $$
+ -- ppr [(arg_id, unfoldingTemplate unf) | Var arg_id <- args, let unf = idUnfolding arg_id, isCheapUnfolding unf] )
+ go ms rs
findBest :: (Id, [CoreExpr])
-> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr)
| ruleCantMatch tpl_tops rough_args = Nothing
| otherwise
= case matchN in_scope tpl_vars tpl_args args of
- Nothing -> Nothing
- Just (binds, tpl_vals, leftovers) -> Just (mkLets binds $
- rule_fn
- `mkApps` tpl_vals
- `mkApps` leftovers)
+ Nothing -> Nothing
+ Just (binds, tpl_vals) -> Just (mkLets binds $
+ rule_fn `mkApps` tpl_vals)
where
rule_fn = occurAnalyseExpr (mkLams tpl_vars rhs)
-- We could do this when putting things into the rulebase, I guess
-> [CoreExpr] -- Template
-> [CoreExpr] -- Target; can have more elts than template
-> Maybe ([CoreBind], -- Bindings to wrap around the entire result
- [CoreExpr], -- What is substituted for each template var
- [CoreExpr]) -- Leftover target exprs
+ [CoreExpr]) -- What is substituted for each template var
matchN in_scope tmpl_vars tmpl_es target_es
- = do { ((tv_subst, id_subst, binds), leftover_es)
+ = do { (tv_subst, id_subst, binds)
<- go init_menv emptySubstEnv tmpl_es target_es
; return (fromOL binds,
- map (lookup_tmpl tv_subst id_subst) tmpl_vars,
- leftover_es) }
+ map (lookup_tmpl tv_subst id_subst) tmpl_vars) }
where
init_menv = ME { me_tmpls = mkVarSet tmpl_vars, me_env = init_rn_env }
init_rn_env = mkRnEnv2 (extendInScopeSetList in_scope tmpl_vars)
- go menv subst [] es = Just (subst, es)
+ go menv subst [] es = Just subst
go menv subst ts [] = Nothing -- Fail if too few actual args
go menv subst (t:ts) (e:es) = do { subst1 <- match menv subst t e
; go menv subst1 ts es }
-}
-- Everything else fails
-match menv subst e1 e2 = Nothing
+match menv subst e1 e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr e1) $$ (text "e2:" <+> ppr e2)) $
+ Nothing
------------------------------------------
match_var :: MatchEnv