Enforcing a stronger difference between the two syntaxes "simpl

reference" and "simpl pattern" in the code (maybe we should have
merged them instead, but I finally decided to enforce their
difference, even if some compatibility is to be preversed - the idea
is that at some time "simpl reference" would only call a weak-head
simpl (or eventually cbn), leading e.g. to reduce 2+n into S(1+n)
rather than S(S(n)) which could be useful for better using induction
hypotheses.

In the process we also implement the following:
- 'simpl "+"' is accepted to reduce all applicative subterms whose
  head symbol is written "+" (in the toplevel scope); idem for
  vm_compute and native_compute
- 'simpl reference' works even if reference has maximally inserted
  implicit arguments (this solves the "simpl fst" incompatibility)
- compatibility of ltac expressions referring to vm_compute and
  native_compute with functor application should now work (i.e.
  vm_compute and native_compute are now taken into account in
  tacsubst.ml)
- for compatibility, "simpl eq" (assuming no maximal implicit args in
  eq) or "simpl @eq" to mean "simpl (eq _ _)" are still allowed.

By the way, is "mul" on nat defined optimally? "3*n" simplifies to
"n+(n+(n+0))". Are there some advantages of this compared to have it
simplified to "n+n+n" (i.e. to "(n+n)+n").

2 files changed, 31 insertions, 0 deletions

diff --git a/pretyping/miscops.ml b/pretyping/miscops.ml
index 83e33f84ea..3e5f7577bf 100644
--- a/pretyping/miscops.ml
+++ b/pretyping/miscops.ml
@@ -6,7 +6,9 @@
 (*         *       GNU Lesser General Public License Version 2.1        *)
 (************************************************************************)
 
+open Util
 open Misctypes
+open Genredexpr
 
 (** Mapping [cast_type] *)
 
@@ -36,3 +38,26 @@ let intro_pattern_naming_eq nam1 nam2 = match nam1, nam2 with
 | IntroIdentifier id1, IntroIdentifier id2 -> Names.Id.equal id1 id2
 | IntroFresh id1, IntroFresh id2 -> Names.Id.equal id1 id2
 | _ -> false
+
+(** Mapping [red_expr_gen] *)
+
+let map_flags f flags =
+  { flags with rConst = List.map f flags.rConst }
+
+let map_occs f (occ,e) = (occ,f e)
+
+let map_union f g = function
+  | Inl a -> Inl (f a)
+  | Inr b -> Inr (g b)
+
+let map_red_expr_gen f g h = function
+  | Fold l -> Fold (List.map f l)
+  | Pattern occs_l -> Pattern (List.map (map_occs f) occs_l)
+  | Simpl occs_o -> Simpl (Option.map (map_occs (map_union g h)) occs_o)
+  | Unfold occs_l -> Unfold (List.map (map_occs g) occs_l)
+  | Cbv flags -> Cbv (map_flags g flags)
+  | Lazy flags -> Lazy (map_flags g flags)
+  | CbvVm occs_o -> CbvVm (Option.map (map_occs (map_union g h)) occs_o)
+  | CbvNative occs_o -> CbvNative (Option.map (map_occs (map_union g h)) occs_o)
+  | Cbn flags -> Cbn (map_flags g flags)
+  | ExtraRedExpr _ | Red _ | Hnf _ as x -> x
diff --git a/pretyping/miscops.mli b/pretyping/miscops.mli
index 6235533d79..eb9b4a7800 100644
--- a/pretyping/miscops.mli
+++ b/pretyping/miscops.mli
@@ -7,6 +7,7 @@
 (************************************************************************)
 
 open Misctypes
+open Genredexpr
 
 (** Mapping [cast_type] *)
 
@@ -21,3 +22,8 @@ val glob_sort_eq : glob_sort -> glob_sort -> bool
 
 val intro_pattern_naming_eq :
   intro_pattern_naming_expr -> intro_pattern_naming_expr -> bool
+
+(** Mapping [red_expr_gen] *)
+
+val map_red_expr_gen : ('a -> 'd) -> ('b -> 'e) -> ('c -> 'f) ->
+  ('a,'b,'c) red_expr_gen -> ('d,'e,'f) red_expr_gen