---
--- ASSUMPTION (A):
--- A1. No top-level variable is bound in the target
--- A2. No template variable is bound in the target
--- A3. No lambda bound template variable is free in any subexpression of the target
---
--- To see why A1 is necessary, consider matching
--- \x->f against \f->f
--- When we meet the lambdas we substitute [f/x] in the template (a no-op),
--- and then erroneously succeed in matching f against f.
---
--- To see why A2 is needed consider matching
--- forall a. \b->b against \a->3
--- When we meet the lambdas we substitute [a/b] in the template, and then
--- erroneously succeed in matching what looks like the template variable 'a' against 3.
---
--- A3 is needed to validate the rule that says
--- (\x->E) matches F
--- if
--- (\x->E) matches (\x->F x)
-
-
-matchRule in_scope rule@(BuiltinRule match_fn) args = match_fn args
-
-matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args
- = go tpl_args args emptySubst
- -- We used to use the in_scope set, but I don't think that's necessary
- -- After all, the result is going to be simplified again with that in_scope set
- where
- tpl_var_set = mkVarSet tpl_vars
-
- -----------------------
- -- Do the business
- go (tpl_arg:tpl_args) (arg:args) subst = match tpl_arg arg tpl_var_set (go tpl_args args) subst
-
- -- Two easy ways to terminate
- go [] [] subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars)
- go [] args subst = Just (rn, app_match subst (mkLams tpl_vars rhs) tpl_vars `mkApps` args)
-
- -- One tiresome way to terminate: check for excess unmatched
- -- template arguments
- go tpl_args [] subst = Nothing -- Failure
-
-
- -----------------------
- app_match subst fn vs = foldl go fn vs
- where
- senv = substEnv subst
- go fn v = case lookupSubstEnv senv v of
- Just (DoneEx ex) -> fn `App` ex
- Just (DoneTy ty) -> fn `App` Type ty
- -- Substitution should bind them all!
-
-
- -----------------------
-{- The code below tries to match even if there are more
- template args than real args.
-
- I now think this is probably a bad idea.
- Should the template (map f xs) match (map g)? I think not.
- For a start, in general eta expansion wastes work.
- SLPJ July 99
-
- = case eta_complete tpl_args (mkVarSet leftovers) of
- Just leftovers' -> Just (rn, mkLams done (mkLams leftovers' rhs),
- mk_result_args subst done)
- Nothing -> Nothing -- Failure
- where
- (done, leftovers) = partition (\v -> maybeToBool (lookupSubstEnv subst_env v))
- (map zapOccInfo tpl_vars)
- -- Zap the occ info
- subst_env = substEnv subst
-
- -----------------------
- eta_complete [] vars = ASSERT( isEmptyVarSet vars )
- Just []
- eta_complete (Type ty:tpl_args) vars
- = case getTyVar_maybe ty of
- Just tv | tv `elemVarSet` vars
- -> case eta_complete tpl_args (vars `delVarSet` tv) of
- Just vars' -> Just (tv:vars')
- Nothing -> Nothing
- other -> Nothing
-
- eta_complete (Var v:tpl_args) vars
- | v `elemVarSet` vars
- = case eta_complete tpl_args (vars `delVarSet` v) of
- Just vars' -> Just (v:vars')
- Nothing -> Nothing
-
- eta_complete other vars = Nothing
-
-
-zapOccInfo bndr | isTyVar bndr = bndr
- | otherwise = zapLamIdInfo bndr
--}
+
+matchRule is_active in_scope rule@(BuiltinRule name match_fn) args
+ = case match_fn args of
+ Just expr -> Just (name,expr)
+ Nothing -> Nothing
+
+matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args
+ | not (is_active act)
+ = Nothing
+ | otherwise
+ = case matchN in_scope tpl_vars tpl_args args of
+ Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers)
+ Nothing -> Nothing
+\end{code}
+
+\begin{code}
+matchN :: InScopeSet
+ -> [Var] -- Template tyvars
+ -> [CoreExpr] -- Template
+ -> [CoreExpr] -- Target; can have more elts than template
+ -> Maybe ([CoreExpr], -- What is substituted for each template var
+ [CoreExpr]) -- Leftover target exprs
+
+matchN in_scope tmpl_vars tmpl_es target_es
+ = do { (subst, leftover_es) <- go init_menv emptySubstEnv tmpl_es target_es
+ ; return (map (lookup_tmpl subst) tmpl_vars, leftover_es) }
+ 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 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 }
+
+ lookup_tmpl :: (TvSubstEnv, IdSubstEnv) -> Var -> CoreExpr
+ lookup_tmpl (tv_subst, id_subst) tmpl_var
+ | isTyVar tmpl_var = case lookupVarEnv tv_subst tmpl_var of
+ Just ty -> Type ty
+ Nothing -> unbound tmpl_var
+ | otherwise = case lookupVarEnv id_subst tmpl_var of
+ Just e -> e
+ other -> unbound tmpl_var
+
+ unbound var = pprPanic "Template variable unbound in rewrite rule" (ppr var)