---
--- ASSUMPTION (A):
--- No variable free in the template is bound in the target
-
-matchRule in_scope (Rule rn tpl_vars tpl_args rhs) args
- = go tpl_args args (mkSubst in_scope emptySubstEnv)
- 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, mkLams tpl_vars rhs, mk_result_args subst tpl_vars)
- go [] args subst = Just (rn, mkLams tpl_vars rhs, mk_result_args subst tpl_vars ++ args)
-
- -- One tiresome way to terminate: check for excess unmatched
- -- template arguments
- go tpl_args [] subst
- = 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
-
- -----------------------
- mk_result_args subst vs = map go vs
- where
- senv = substEnv subst
- go v = case lookupSubstEnv senv v of
- Just (DoneEx ex) -> ex
- Just (DoneTy ty) -> Type ty
- -- Substitution should bind them all!
-
-zapOccInfo bndr | isTyVar bndr = bndr
- | otherwise = maybeModifyIdInfo 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